Utils.hs

{-
Copyright (C) 2006-2008 John Goerzen <jgoerzen@complete.org>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- |
   Module     : Utils
   Copyright  : Copyright (C) 2006-2008 John Goerzen
   License    : GNU GPL, version 2 or above

   Maintainer : John Goerzen <jgoerzen@complete.org>
   Stability  : provisional
   Portability: portable

Written by John Goerzen, jgoerzen\@complete.org

-}

module Utils where
import System.Console.GetOpt
import Types
import System.Exit
import System.IO
import Data.ConfigFile
import Text.Regex.Posix
import Data.Either.Utils(forceEither)
import Network.URI
import Data.Maybe.Utils
import Text.Printf

simpleCmd :: String             -- ^ Command name
          -> String             -- ^ Command description
          -> String             -- ^ Command help text
          -> [OptDescr (String, String)] -- ^ Option descriptions
          -> (Maybe String -> ConfigParser -> ([(String, String)], [String]) -> IO ()) -- ^ Function to call 
          -> (String, Command)
simpleCmd name descrip helptext optionsinp func =
    (name, Command {cmdname = name, cmddescrip = descrip,
                    execcmd = worker})
    where options =
              optionsinp ++ [Option "" ["help"] (NoArg ("help", "")) "Display this help"]
          worker argv cpath gi =
              case getOpt RequireOrder options argv of
                (o, n, []) -> 
                    if (lookup "help" o == Just "") 
                       then usageerror []
                       else func cpath gi (o, n)
                (_, _, errors) -> usageerror (concat errors)
          usageerror errormsg =
              do putStrLn $ "Error processing arguments for command " ++ 
                          name ++ ":"
                 putStrLn errormsg
                 putStrLn (usageInfo header options)
                 putStrLn helptext
                 exitFailure
          header = "Available command-options for " ++ name ++ " are:\n"
                                                               
{-
lock func =
    do appdir <- getAppDir
       lockh <- openFile (appdir ++ "/.lock") WriteMode
       lockfd <- handleToFd lockh
       catch (placelock lockfd) errorhandler
       r <- finally func (releaselock lockfd)
       return r

    where placelock lockfd = setLock lockfd (WriteLock, AbsoluteSeek, 0, 0)
          releaselock lockfd = do
               setLock lockfd (Unlock, AbsoluteSeek, 0, 0)
               closeFd lockfd
          errorhandler _ =
              do putStrLn "Aborting because another twidge is already running"
                 exitFailure
-}

ex_tempfail = 75
ex_permfail = 69

permFail :: String -> IO a
permFail msg =
    do hPutStrLn stderr msg
       exitWith (ExitFailure ex_permfail)

serverHost cp = host
    where urlbase = forceEither $ get cp "DEFAULT" "urlbase"
          uri = forceMaybeMsg "genMsgId parseURI" $ parseURI urlbase
          host = uriRegName . forceMaybeMsg "genMsgId uriauth" . 
                 uriAuthority $ uri

genMsgId :: String -> Message -> ConfigParser -> String
genMsgId section m cp =
    printf "<%s.%s.%s@%s.%s.twidge>" (sId m) (sSender m) (sRecipient m)
               section (serverHost cp) 
-- FIXME: escape periods in serverHost

{- | Parses a message id, returning (Message, host, section).
The sText and sDate fiels will be empty. -}
parseMsgId :: String -> Maybe (Message, String, String)
parseMsgId msgid =
    case msgid =~ repat of
      [[_, id, sender, recipient, section, host]] -> 
          Just (Message {sId = id, sSender = sender, sRecipient = recipient, 
                         sText = "", sDate = ""},
                host, section)
      _ -> Nothing
    where repat = "^<([^.@]+)\\.([^.@]+)\\.([^@.]*)@([^.]+)\\.(.+)\\.twidge>"

----------------------------------------------------------------------
-- Start of code from Cabal 1.4.0.2

-- | Wraps text to the default line width. Existing newlines are preserved.
wrapText :: String -> String
wrapText = unlines
         . concatMap (map unwords
                    . wrapLine 79
                    . words)
         . lines

-- | Wraps a list of words to a list of lines of words of a particular width.
wrapLine :: Int -> [String] -> [[String]]
wrapLine width = wrap 0 []
  where wrap :: Int -> [String] -> [String] -> [[String]]
        wrap 0   []   (w:ws)
          | length w + 1 > width
          = wrap (length w) [w] ws
        wrap col line (w:ws)
          | col + length w + 1 > width
          = reverse line : wrap 0 [] (w:ws)
        wrap col line (w:ws)
          = let col' = col + length w + 1
             in wrap col' (w:line) ws
        wrap _ []   [] = []
        wrap _ line [] = [reverse line]

-- End of code from Cabal 1.4.0.2
----------------------------------------------------------------------