Permalink
Fetching contributors…
Cannot retrieve contributors at this time
150 lines (129 sloc) 5.31 KB
{-
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
----------------------------------------------------------------------