HaskellNet (empty) → 0.2.1
raw patch · 16 files changed
+3719/−0 lines, 16 filesdep +Cryptodep +HaXmldep +arraysetup-changed
Dependencies added: Crypto, HaXml, array, base, base64-string, bytestring, containers, haskell98, mtl, network, old-locale, old-time, parsec, pretty, time
Files
- Data/Record.hs +56/−0
- HaskellNet.cabal +28/−0
- HaskellNet/Auth.hs +75/−0
- HaskellNet/BSStream.hs +58/−0
- HaskellNet/IMAP.hs +471/−0
- HaskellNet/POP3.hs +296/−0
- HaskellNet/SMTP.hs +249/−0
- Setup.hs +3/−0
- Text/Atom.hs +643/−0
- Text/Bencode.hs +152/−0
- Text/IMAPParsers.hs +492/−0
- Text/Mime.hs +343/−0
- Text/Packrat/Parse.hs +351/−0
- Text/Packrat/Pos.hs +33/−0
- Text/RSS.hs +239/−0
- Text/URI.hsc +230/−0
+ Data/Record.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+----------------------------------------------------------------------+-- |+-- Module : Data.Record+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : stable+-- Portability : GHC only+-- +-- Polymorphic record definitions+-- +-- To see the usage of this module, you refer Text.Atom+-- ++++module Data.Record+ (Attr(..), get, set, update, has, add, howMany, set', get', delete)+where++import Control.Applicative+import Data.Foldable+import Data.Monoid+import Prelude hiding (foldr1)++data Attr r v = Attr { getter :: r -> v+ , setter :: r -> v -> r+ }++get :: Attr r v -> r -> v+get = getter+set :: Attr r v -> v -> r -> r+set a v r = setter a r v+update :: Attr r v -> (v -> v) -> r -> r+update a f r = set a (f $ get a r) r++has :: (Foldable t) => Attr r (t v) -> r -> Bool+has a r = howMany a r > 0++add :: (Alternative t) => Attr r (t v) -> v -> r -> r+add a v r = update a (pure v <|>) r++howMany :: (Foldable t, Integral n) => Attr r (t v) -> r -> n+howMany a r = getSum $ foldMap (const (Sum 1)) $ get a r++set' :: (Applicative t, Foldable t) => Attr r (t v) -> v -> r -> r+set' a v r | has a r = r+ | otherwise = set a (pure v) r+get' :: (Foldable t) => Attr r (t v) -> r -> v+get' a r = foldr1 const $ get a r++delete :: (Alternative t) => Attr r (t v) -> r -> r+delete a r = set a empty r+
+ HaskellNet.cabal view
@@ -0,0 +1,28 @@+Name: HaskellNet+Version: 0.2.1+Author: Jun Mukai+Maintainer: Robert Wills <wrwills@gmail.com>+License: BSD3+Category: Network+Description: Originally written for Google SOC, provides network related libraries such as POP3, SMTP, IMAP. + All I have done is get the project to compile using cabal and check that these libraries basically + work. +Build-Depends: base, haskell98, network, mtl, parsec, time, bytestring, pretty, array, Crypto, base64-string, containers, HaXml, old-locale, old-time+Synopsis: network related libraries such as POP3, SMTP, IMAP+cabal-version: >=1.2+build-type: Simple+++exposed-modules:+ Text.IMAPParsers,+ Text.Mime,+ Text.URI,+ Text.Bencode,+ Text.RSS,+ Text.Atom,+ HaskellNet.IMAP,+ HaskellNet.SMTP,+ HaskellNet.POP3,+ HaskellNet.BSStream,+ HaskellNet.Auth+other-modules: Data.Record, Text.Packrat.Pos, Text.Packrat.Parse
+ HaskellNet/Auth.hs view
@@ -0,0 +1,75 @@+----------------------------------------------------------------------+-- |+-- Module : HaskellNet.Auth+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : stable+-- Portability : portable+-- +-- Authentication related APIs+-- ++module HaskellNet.Auth+where++import Data.Digest.MD5+import Codec.Utils+import qualified Codec.Binary.Base64.String as B64 (encode, decode)++import Data.List+import Data.Bits+import Data.Array++type UserName = String+type Password = String++data AuthType = PLAIN+ | LOGIN+ | CRAM_MD5+ deriving Eq++instance Show AuthType where+ showsPrec d at = showParen (d>app_prec) $ showString $ showMain at+ where app_prec = 10+ showMain PLAIN = "PLAIN"+ showMain LOGIN = "LOGIN"+ showMain CRAM_MD5 = "CRAM-MD5"++b64Encode :: String -> String+b64Encode = map (toEnum.fromEnum) . B64.encode . map (toEnum.fromEnum)++b64Decode :: String -> String+b64Decode = map (toEnum.fromEnum) . B64.decode . map (toEnum.fromEnum)++showOctet :: [Octet] -> String+showOctet = concat . map hexChars+ where hexChars c = [arr ! (c `div` 16), arr ! (c `mod` 16)]+ arr = listArray (0, 15) "0123456789abcdef"++hmacMD5 :: String -> String -> [Octet]+hmacMD5 text key = hash $ okey ++ hash (ikey ++ map (toEnum.fromEnum) text)+ where koc = map (toEnum.fromEnum) key+ key' = if length koc > 64+ then hash koc ++ replicate 48 0+ else koc ++ replicate (64-length koc) 0+ ipad = replicate 64 0x36+ opad = replicate 64 0x5c+ ikey = zipWith xor key' ipad+ okey = zipWith xor key' opad++plain :: UserName -> Password -> String+plain user pass = b64Encode $ concat $ intersperse "\0" [user, user, pass]++login :: UserName -> Password -> (String, String)+login user pass = (b64Encode user, b64Encode pass)++cramMD5 :: String -> UserName -> Password -> String+cramMD5 challenge user pass =+ b64Encode (user ++ " " ++ showOctet (hmacMD5 challenge pass))++auth :: AuthType -> String -> UserName -> Password -> String+auth PLAIN _ u p = plain u p+auth LOGIN _ u p = let (u', p') = login u p in unwords [u', p']+auth CRAM_MD5 c u p = cramMD5 c u p
+ HaskellNet/BSStream.hs view
@@ -0,0 +1,58 @@+-----------------------------------------------------------------------------+-- |+-- Module : HaskellNet.Stream+-- Copyright : (c) Jun Mukai 2006+-- License : BSD+--+-- Maintainer : mukai@jmuk.org+-- Stability : experimental+-- Portability : portable+--+-- A library for abstracting sockets suitable to Streams.+--+-- +-----------------------------------------------------------------------------++module HaskellNet.BSStream+ ( BSStream(..)+ )+where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Control.Monad.Trans+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO)+import Network++++class BSStream h where+ bsGetLine :: h -> IO ByteString+ bsGet :: h -> Int -> IO ByteString+ bsPut :: h -> ByteString -> IO ()+ bsPuts :: h -> [ByteString] -> IO ()+ bsPutStrLn :: h -> ByteString -> IO ()+ bsPutCrLf :: h -> ByteString -> IO ()+ bsPutNoFlush :: h -> ByteString -> IO ()+ bsFlush :: h -> IO ()+ bsClose :: h -> IO ()++ bsPuts h strs = mapM_ (bsPut h) strs+ bsPutCrLf h s = bsPut h s >> bsPut h crlf+ bsPutStrLn h s = bsPut h s >> bsPut h lf++lf = BS.singleton '\n' +crlf = BS.pack "\r\n"++blocklen = 4096+waiting = 500 -- miliseconds++instance BSStream Handle where+ bsGetLine = BS.hGetLine+ bsGet = BS.hGet+ bsPut h s = BS.hPut h s >> bsFlush h+ bsPutStrLn h s = BS.hPutStrLn h s >> bsFlush h+ bsPutNoFlush = BS.hPut+ bsFlush = hFlush+ bsClose = hClose
+ HaskellNet/IMAP.hs view
@@ -0,0 +1,471 @@+----------------------------------------------------------------------+-- |+-- Module : HaskellNet.IMAP+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : stable+-- Portability : portable+-- +-- IMAP client implementation+-- ++module HaskellNet.IMAP+ ( -- * connection type and corresponding actions+ IMAPConnection+ , mailbox, exists, recent+ , flags, permanentFlags, isWritable, isFlagWritable+ , uidNext, uidValidity+ , stream+ , connectIMAP, connectIMAPPort, connectStream+ -- * IMAP commands+ -- ** any state commands+ , noop, capability, logout+ -- ** not authenticated state commands+ , login, authenticate+ -- ** autenticated state commands+ , select, examine, create, delete, rename+ , subscribe, unsubscribe+ , list, lsub, status, append+ -- ** selected state commands+ , check, close, expunge+ , search, store, copy+ -- * fetch commands+ , fetch, fetchHeader, fetchSize, fetchHeaderFields, fetchHeaderFieldsNot+ , fetchFlags, fetchR, fetchByString, fetchByStringR+ -- * other types+ , Flag(..), Attribute(..), MailboxStatus(..)+ , SearchQuery(..), FlagsQuery(..)+ )+where++import Network+import HaskellNet.BSStream+import HaskellNet.Auth hiding (auth, login)+import qualified HaskellNet.Auth as A++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS++import Data.Digest.MD5+import Control.Monad+import Control.Monad.Writer++import System.IO+import System.Time++import Data.IORef+import Data.Maybe+import Data.Word+import Data.List hiding (delete)+import Data.Char++import Text.IMAPParsers hiding (exists, recent)+import Text.Packrat.Parse (Result)+++----------------------------------------------------------------------+-- connection type and corresponding functions+data BSStream s => IMAPConnection s = + IMAPC s (IORef MailboxInfo) (IORef Int)++mailbox :: BSStream s => IMAPConnection s -> IO Mailbox+mailbox (IMAPC _ mbox _) = fmap _mailbox $ readIORef mbox+exists, recent :: BSStream s => IMAPConnection s -> IO Integer+exists (IMAPC _ mbox _) = fmap _exists $ readIORef mbox+recent (IMAPC _ mbox _) = fmap _recent $ readIORef mbox++flags, permanentFlags :: BSStream s => IMAPConnection s -> IO [Flag]+flags (IMAPC _ mbox _) = fmap _flags $ readIORef mbox+permanentFlags (IMAPC _ mbox _) = fmap _permanentFlags $ readIORef mbox++isWritable, isFlagWritable :: BSStream s => IMAPConnection s -> IO Bool+isWritable (IMAPC _ mbox _) = fmap _isWritable $ readIORef mbox+isFlagWritable (IMAPC _ mbox _) = fmap _isFlagWritable $ readIORef mbox++uidNext, uidValidity :: BSStream s => IMAPConnection s -> IO UID+uidNext (IMAPC _ mbox _) = fmap _uidNext $ readIORef mbox+uidValidity (IMAPC _ mbox _) = fmap _uidValidity $ readIORef mbox++stream :: BSStream s => IMAPConnection s -> s+stream (IMAPC s _ _) = s+++++-- suffixed by `s'+data SearchQuery = ALLs+ | FLAG Flag+ | UNFLAG Flag+ | BCCs String+ | BEFOREs CalendarTime+ | BODYs String+ | CCs String+ | FROMs String+ | HEADERs String String+ | LARGERs Integer+ | NEWs+ | NOTs SearchQuery+ | OLDs+ | ONs CalendarTime+ | ORs SearchQuery SearchQuery+ | SENTBEFOREs CalendarTime+ | SENTONs CalendarTime+ | SENTSINCEs CalendarTime+ | SINCEs CalendarTime+ | SMALLERs Integer+ | SUBJECTs String+ | TEXTs String+ | TOs String+ | UIDs [UID]+++instance Show SearchQuery where+ showsPrec d q = showParen (d>app_prec) $ showString $ showQuery q+ where app_prec = 10+ showQuery ALLs = "ALL"+ showQuery (FLAG f) = showFlag f+ showQuery (UNFLAG f) = "UN" ++ showFlag f+ showQuery (BCCs addr) = "BCC " ++ addr+ showQuery (BEFOREs t) = "BEFORE " ++ dateToStringIMAP t+ showQuery (BODYs s) = "BODY " ++ s+ showQuery (CCs addr) = "CC " ++ addr+ showQuery (FROMs addr) = "FROM " ++ addr+ showQuery (HEADERs f v) = "HEADER " ++ f ++ " " ++ v+ showQuery (LARGERs siz) = "LARGER {" ++ show siz ++ "}"+ showQuery NEWs = "NEW"+ showQuery (NOTs q) = "NOT " ++ show q+ showQuery OLDs = "OLD"+ showQuery (ONs t) = "ON " ++ dateToStringIMAP t+ showQuery (ORs q1 q2) = "OR " ++ show q1 ++ " " ++ show q2 + showQuery (SENTBEFOREs t) = "SENTBEFORE " ++ dateToStringIMAP t+ showQuery (SENTONs t) = "SENTON " ++ dateToStringIMAP t+ showQuery (SENTSINCEs t) = "SENTSINCE " ++ dateToStringIMAP t+ showQuery (SINCEs t) = "SINCE " ++ dateToStringIMAP t+ showQuery (SMALLERs siz) = "SMALLER {" ++ show siz ++ "}"+ showQuery (SUBJECTs s) = "SUBJECT " ++ s+ showQuery (TEXTs s) = "TEXT " ++ s+ showQuery (TOs addr) = "TO " ++ addr+ showQuery (UIDs uids) = concat $ intersperse "," $ map show uids+ showFlag Seen = "SEEN"+ showFlag Answered = "ANSWERED"+ showFlag Flagged = "FLAGGED"+ showFlag Deleted = "DELETED"+ showFlag Draft = "DRAFT"+ showFlag Recent = "RECENT"+ showFlag (Keyword s) = "KEYWORD " ++ s+ ++data FlagsQuery = ReplaceFlags [Flag]+ | PlusFlags [Flag]+ | MinusFlags [Flag]++++----------------------------------------------------------------------+-- establish connection++connectIMAPPort :: String -> PortNumber -> IO (IMAPConnection Handle)+connectIMAPPort hostname port = connectTo hostname (PortNumber port) >>= connectStream++connectIMAP :: String -> IO (IMAPConnection Handle)+connectIMAP hostname = connectIMAPPort hostname 143++connectStream :: BSStream s => s -> IO (IMAPConnection s)+connectStream s =+ do msg <- bsGetLine s+ unless (and $ BS.zipWith (==) msg (BS.pack "* OK")) $ fail "cannot connect to the server"+ mbox <- newIORef emptyMboxInfo+ c <- newIORef 0+ return $ IMAPC s mbox c++emptyMboxInfo = MboxInfo "" 0 0 [] [] False False 0 0++----------------------------------------------------------------------+-- normal send commands+sendCommand' :: BSStream s => IMAPConnection s -> String -> IO ByteString+sendCommand' (IMAPC s mbox nr) cmdstr =+ do num <- readIORef nr + bsPutCrLf s $ BS.pack $ show6 num ++ " " ++ cmdstr+ modifyIORef nr (+1)+ getResponse s++show6 n | n > 100000 = show n+ | n > 10000 = '0' : show n+ | n > 1000 = "00" ++ show n+ | n > 100 = "000" ++ show n+ | n > 10 = "0000" ++ show n+ | otherwise = "00000" ++ show n++sendCommand :: BSStream s => IMAPConnection s -> String -> (RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, v)) -> IO v+sendCommand imapc@(IMAPC _ mbox nr) cmdstr pFunc =+ do num <- readIORef nr+ buf <- sendCommand' imapc cmdstr+ let (resp, mboxUp, value) = eval pFunc (show6 num) buf+ case resp of+ OK _ _ -> do mboxUpdate mbox $ mboxUp+ return value+ NO _ msg -> fail ("NO: " ++ msg)+ BAD _ msg -> fail ("BAD: " ++ msg)+ PREAUTH _ msg -> fail ("preauth: " ++ msg)++getResponse :: BSStream s => s -> IO ByteString+getResponse s = fmap unlinesCRLF getLs+ where unlinesCRLF = BS.concat . concatMap (:[crlf]) + getLs = + do l <- fmap strip $ bsGetLine s+ case () of+ _ | isLiteral l -> do l' <- getLiteral l (getLitLen l)+ ls <- getLs+ return (l' : ls)+ | isTagged l -> fmap (l:) getLs+ | otherwise -> return [l]+ getLiteral l len = + do lit <- bsGet s len+ l2 <- fmap strip $ bsGetLine s+ let l' = BS.concat [l, crlf, lit, l2]+ if isLiteral l2+ then getLiteral l' (getLitLen l2)+ else return l'+ crlf = BS.pack "\r\n"+ isLiteral l = BS.last l == '}' && BS.last (fst (BS.spanEnd isDigit (BS.init l))) == '{'+ getLitLen = read . BS.unpack . snd . BS.spanEnd isDigit . BS.init+ isTagged l = BS.head l == '*' && BS.head (BS.tail l) == ' '++mboxUpdate :: IORef MailboxInfo -> MboxUpdate -> IO ()+mboxUpdate mbox (MboxUpdate exists recent) =+ do when (isJust exists) $ do mb <- readIORef mbox+ writeIORef mbox (mb { _exists = e })+ when (isJust recent) $ do mb <- readIORef mbox+ writeIORef mbox (mb { _recent = r })+ where e = fromJust exists+ r = fromJust recent++----------------------------------------------------------------------+-- IMAP commands+-- ++noop :: BSStream s => IMAPConnection s -> IO ()+noop conn@(IMAPC s mbox _) = sendCommand conn "NOOP" pNone++capability :: BSStream s => IMAPConnection s -> IO [String]+capability conn = sendCommand conn "CAPABILITY" pCapability++logout :: BSStream s => IMAPConnection s -> IO ()+logout conn@(IMAPC s _ _) = do bsPutCrLf s $ BS.pack "a0001 LOGOUT"+ bsClose s++login :: BSStream s => IMAPConnection s -> UserName -> Password -> IO ()+login conn user pass = sendCommand conn ("LOGIN " ++ user ++ " " ++ pass) pNone++select, examine, create, delete :: BSStream s =>+ IMAPConnection s -> Mailbox -> IO ()+_select cmd conn@(IMAPC s mbox _) mboxName =+ do mbox' <- sendCommand conn (cmd ++ mboxName) pSelect+ writeIORef mbox (mbox' { _mailbox = mboxName })++authenticate :: BSStream s => IMAPConnection s -> AuthType -> UserName -> Password -> IO ()+authenticate conn@(IMAPC s mbox nr) LOGIN user pass =+ do num <- readIORef nr+ sendCommand' conn "AUTHENTICATE LOGIN"+ bsPutCrLf s $ BS.pack userB64+ bsGetLine s+ bsPutCrLf s $ BS.pack passB64+ buf <- getResponse s+ let (resp, mboxUp, value) = eval pNone (show6 num) buf+ case resp of+ OK _ _ -> do mboxUpdate mbox $ mboxUp+ return value+ NO _ msg -> fail ("NO: " ++ msg)+ BAD _ msg -> fail ("BAD: " ++ msg)+ PREAUTH _ msg -> fail ("preauth: " ++ msg)+ where (userB64, passB64) = A.login user pass+authenticate conn@(IMAPC s mbox nr) at user pass =+ do num <- readIORef nr+ c <- sendCommand' conn $ "AUTHENTICATE " ++ show at+ let challenge =+ if BS.take 2 c == BS.pack "+ "+ then b64Decode $ BS.unpack $ head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c+ else ""+ bsPutCrLf s $ BS.pack $ A.auth at challenge user pass+ buf <- getResponse s+ let (resp, mboxUp, value) = eval pNone (show6 num) buf+ case resp of+ OK _ _ -> do mboxUpdate mbox $ mboxUp+ return value+ NO _ msg -> fail ("NO: " ++ msg)+ BAD _ msg -> fail ("BAD: " ++ msg)+ PREAUTH _ msg -> fail ("preauth: " ++ msg)++select = _select "SELECT "+examine = _select "EXAMINE "+create conn mboxname = sendCommand conn ("CREATE " ++ mboxname) pNone+delete conn mboxname = sendCommand conn ("DELETE " ++ mboxname) pNone++rename :: BSStream s => IMAPConnection s -> Mailbox -> Mailbox -> IO ()+rename conn mboxorg mboxnew =+ sendCommand conn ("RENAME " ++ mboxorg ++ " " ++ mboxnew) pNone++subscribe, unsubscribe :: BSStream s => IMAPConnection s -> Mailbox -> IO ()+subscribe conn mboxname = sendCommand conn ("SUBSCRIBE " ++ mboxname) pNone+unsubscribe conn mboxname = sendCommand conn ("UNSUBSCRIBE " ++ mboxname) pNone++list, lsub :: BSStream s => IMAPConnection s -> IO [([Attribute], Mailbox)]+list conn = fmap (map (\(a, _, m) -> (a, m))) $ listFull conn "\"\"" "*"+lsub conn = fmap (map (\(a, _, m) -> (a, m))) $ lsubFull conn "\"\"" "*"++listPat, lsubPat :: BSStream s => IMAPConnection s -> String -> IO [([Attribute], String, Mailbox)]+listPat conn pat = listFull conn "\"\"" pat+lsubPat conn pat = lsubFull conn "\"\"" pat++listFull, lsubFull :: BSStream s => IMAPConnection s -> String -> String -> IO [([Attribute], String, Mailbox)]+listFull conn ref pat = sendCommand conn (unwords ["LIST", ref, pat]) pList+lsubFull conn ref pat = sendCommand conn (unwords ["LSUB", ref, pat]) pLsub++status :: BSStream s => IMAPConnection s -> Mailbox -> [MailboxStatus] -> IO [(MailboxStatus, Integer)]+status conn mbox stats =+ sendCommand conn ("STATUS " ++ mbox ++ " (" ++ (unwords $ map show stats) ++ ")") pStatus++append :: BSStream s => IMAPConnection s -> Mailbox -> ByteString -> IO ()+append conn mbox mailData = appendFull conn mbox mailData [] Nothing++appendFull :: BSStream s => IMAPConnection s -> Mailbox -> ByteString -> [Flag] -> Maybe CalendarTime -> IO ()+appendFull conn@(IMAPC s mbInfo nr) mbox mailData flags time = + do num <- readIORef nr+ buf <- sendCommand' conn+ (unwords ["APPEND", mbox+ , fstr, tstr, "{" ++ show len ++ "}"])+ unless (BS.null buf || (BS.head buf /= '+')) $ fail "illegal server response"+ mapM_ (bsPutCrLf s) mailLines+ buf <- getResponse s+ let (resp, mboxUp, ()) = eval pNone (show6 num) buf+ case resp of+ OK _ _ -> mboxUpdate mbInfo mboxUp+ NO _ msg -> fail ("NO: "++msg)+ BAD _ msg -> fail ("BAD: "++msg)+ PREAUTH _ msg -> fail ("PREAUTH: "++msg)+ where mailLines = BS.lines mailData+ len = sum $ map ((2+) . BS.length) mailLines+ tstr = maybe "" show time+ fstr = unwords $ map show flags++check :: BSStream s => IMAPConnection s -> IO ()+check conn = sendCommand conn "CHECK" pNone++close :: BSStream s => IMAPConnection s -> IO ()+close conn@(IMAPC s mbox _) =+ do sendCommand conn "CLOSE" pNone+ writeIORef mbox emptyMboxInfo++expunge :: BSStream s => IMAPConnection s -> IO [Integer]+expunge conn = sendCommand conn "EXPUNGE" pExpunge++search :: BSStream s => IMAPConnection s -> [SearchQuery] -> IO [UID]+search conn queries = searchCharset conn "" queries++searchCharset :: BSStream s => IMAPConnection s -> Charset -> [SearchQuery] -> IO [UID]+searchCharset conn charset queries =+ sendCommand conn ("UID SEARCH " ++ charset ++ " " ++ unwords (map show queries)) pSearch++fetch, fetchHeader :: BSStream s => IMAPConnection s -> UID -> IO ByteString+fetch conn uid =+ do lst <- fetchByString conn uid "BODY[]"+ return $ maybe BS.empty BS.pack $ lookup "BODY[]" lst+fetchHeader conn uid =+ do lst <- fetchByString conn uid "BODY[HEADER]"+ return $ maybe BS.empty BS.pack $ lookup "BODY[HEADER]" lst+fetchSize :: BSStream s => IMAPConnection s -> UID -> IO Int+fetchSize conn uid =+ do lst <- fetchByString conn uid "RFC822.SIZE"+ return $ maybe 0 read $ lookup "RFC822.SIZE" lst+fetchHeaderFields, fetchHeaderFieldsNot :: BSStream s => IMAPConnection s -> UID -> [String] -> IO ByteString+fetchHeaderFields conn uid hs =+ do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS "++unwords hs++"]")+ return $ maybe BS.empty BS.pack $+ lookup ("BODY[HEADER.FIELDS "++unwords hs++"]") lst+fetchHeaderFieldsNot conn uid hs = + do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS.NOT "++unwords hs++"]")+ return $ maybe BS.empty BS.pack $ lookup ("BODY[HEADER.FIELDS.NOT "++unwords hs++"]") lst+fetchFlags :: BSStream s => IMAPConnection s -> UID -> IO [Flag]+fetchFlags conn uid =+ do lst <- fetchByString conn uid "FLAGS"+ return $ getFlags $ lookup "FLAGS" lst+ where getFlags Nothing = []+ getFlags (Just s) = eval' dvFlags "" s++fetchR :: BSStream s => IMAPConnection s -> (UID, UID) -> IO [(UID, ByteString)]+fetchR conn r =+ do lst <- fetchByStringR conn r "BODY[]"+ return $ map (\(uid, vs) -> (uid, maybe BS.empty BS.pack $ lookup "BODY[]" vs)) lst+fetchByString :: BSStream s => IMAPConnection s -> UID -> String -> IO [(String, String)]+fetchByString conn uid command =+ do lst <- fetchCommand conn ("UID FETCH "++show uid++" "++command) id+ return $ snd $ head lst+fetchByStringR :: BSStream s => IMAPConnection s -> (UID, UID) -> String -> IO [(UID, [(String, String)])]+fetchByStringR conn (s, e) command =+ fetchCommand conn ("UID FETCH "++show s++":"++show e++" "++command) proc+ where proc (n, ps) =+ (maybe (toEnum (fromIntegral n)) read (lookup "UID" ps), ps)++fetchCommand conn command proc =+ fmap (map proc) $ sendCommand conn command pFetch++storeFull :: BSStream s => IMAPConnection s -> String -> FlagsQuery -> Bool -> IO [(UID, [Flag])]+storeFull conn uidstr query isSilent =+ fetchCommand conn ("UID STORE " ++ uidstr ++ flags query) procStore+ where fstrs fs = "(" ++ (concat $ intersperse " " $ map show fs) ++ ")"+ toFStr s fstrs =+ s ++ (if isSilent then ".SILENT" else "") ++ " " ++ fstrs+ flags (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs+ flags (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs+ flags (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs+ procStore (n, ps) = (maybe (toEnum (fromIntegral n)) read+ (lookup "UID" ps)+ ,maybe [] (eval' dvFlags "") (lookup "FLAG" ps))+++store :: BSStream s => IMAPConnection s -> UID -> FlagsQuery -> IO ()+storeR :: BSStream s => IMAPConnection s -> (UID, UID) -> FlagsQuery -> IO ()+store conn i q = storeFull conn (show i) q True >> return ()+storeR conn (s, e) q = storeFull conn (show s++":"++show e) q True >> return ()+-- storeResults is used without .SILENT, so that its response contains its result flags+storeResults :: BSStream s => IMAPConnection s -> UID -> FlagsQuery -> IO [Flag]+storeResultsR :: BSStream s => IMAPConnection s -> (UID, UID) -> FlagsQuery -> IO [(UID, [Flag])]+storeResults conn i q =+ storeFull conn (show i) q False >>= return . snd . head+storeResultsR conn (s, e) q = storeFull conn (show s++":"++show e) q False++copy :: BSStream s => IMAPConnection s -> UID -> Mailbox -> IO ()+copyR :: BSStream s => IMAPConnection s -> (UID, UID) -> Mailbox -> IO ()+copyFull conn uidStr mbox =+ sendCommand conn ("UID COPY " ++ uidStr ++ " " ++ mbox) pNone++copy conn uid mbox = copyFull conn (show uid) mbox+copyR conn (s, e) mbox = copyFull conn (show s++":"++show e) mbox+++----------------------------------------------------------------------+-- auxialiary functions++dateToStringIMAP :: CalendarTime -> String+dateToStringIMAP date = concat $ intersperse "-" [show2 $ ctDay date+ , showMonth $ ctMonth date+ , show $ ctYear date]+ where show2 n | n < 10 = '0' : show n+ | otherwise = show n+ showMonth January = "Jan"+ showMonth February = "Feb"+ showMonth March = "Mar"+ showMonth April = "Apr"+ showMonth May = "May"+ showMonth June = "Jun"+ showMonth July = "Jul"+ showMonth August = "Aug"+ showMonth September = "Sep"+ showMonth October = "Oct"+ showMonth November = "Nov"+ showMonth December = "Dec"++strip :: ByteString -> ByteString+strip = fst . BS.spanEnd isSpace . BS.dropWhile isSpace
+ HaskellNet/POP3.hs view
@@ -0,0 +1,296 @@+----------------------------------------------------------------------+-- |+-- Module : HaskellNet.POP3+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : stable+-- Portability : portable+-- +-- POP3 client implementation+-- ++module HaskellNet.POP3+ ( -- * Types+ Command(..)+ , POP3Connection(..)+ , Response(..)+ -- * Establishing Connection+ , connectPop3Port+ , connectPop3+ , connectStream+ -- * Send Command+ , sendCommand+ -- * More Specific Operations+ , closePop3+ , user+ , pass+ , userPass+ , apop+ , auth+ , stat+ , dele+ , retr+ , top+ , rset+ , allList+ , list+ , allUIDLs+ , uidl+ -- * Other Useful Operations+ , doPop3Port+ , doPop3+ , doPop3Stream+ )+ where++import HaskellNet.BSStream+import Network+import HaskellNet.Auth hiding (auth, login)+import qualified HaskellNet.Auth as A++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Digest.MD5+import Numeric (showHex)++import Control.Exception+import Control.Monad (when, unless)++import Data.List+import Data.Char (isSpace, isControl)++import System.IO++import qualified Data.ByteString.Char8 as BSC++import Prelude hiding (catch)++data BSStream s => POP3Connection s = POP3C !s !String -- ^ APOP key++data Command = USER UserName+ | PASS Password+ | APOP UserName Password+ | AUTH AuthType UserName Password+ | NOOP+ | QUIT+ | STAT+ | LIST (Maybe Int)+ | DELE Int+ | RETR Int+ | RSET+ | TOP Int Int+ | UIDL (Maybe Int)++data Response = Ok | Err + deriving (Eq, Show)+++hexDigest = concatMap (flip showHex "") . hash . map (toEnum.fromEnum) ++strip :: ByteString -> ByteString+strip = trimR . trimR + where + trimR s = let rs = BS.reverse s in+ BS.dropWhile blank rs++blank :: Char -> Bool+blank a = isSpace a || isControl a+--strip s = head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.dropWhile isSpace s+++-- |+-- connecting to the pop3 server specified by the hostname and port number+connectPop3Port :: String -> PortNumber -> IO (POP3Connection Handle)+connectPop3Port hostname port = connectTo hostname (PortNumber port) >>= connectStream++-- |+-- connecting to the pop3 server specified by the hostname. 110 is used for the port number.+connectPop3 :: String -> IO (POP3Connection Handle)+connectPop3 = flip connectPop3Port 110++-- |+-- connecting to the pop3 server via a stream+connectStream :: BSStream s => s -> IO (POP3Connection s)+connectStream st =+ do (resp, msg) <- response st+ when (resp == Err) $ fail "cannot connect"+ let code = last $ BS.words msg+ if BS.head code == '<' && BS.last code == '>'+ then return $ POP3C st (BS.unpack code)+ else return $ POP3C st ""+++response :: BSStream s => s -> IO (Response, ByteString)+response st =+ do reply <- fmap strip $ bsGetLine st+ if (BS.pack "+OK") `BS.isPrefixOf` reply+ then return (Ok, BS.drop 4 reply)+ else return (Err, BS.drop 5 reply)++-- | parse mutiline of response+responseML :: BSStream s => s -> IO (Response, ByteString)+responseML st =+ do reply <- fmap strip $ bsGetLine st+ if (BS.pack "+OK") `BS.isPrefixOf` reply+ then do rest <- getRest+ return (Ok, BS.unlines (BS.drop 4 reply : rest))+ else return (Err, BS.drop 5 reply)+ where getRest = do l <- fmap strip $ bsGetLine st+ if l == BS.singleton '.'+ then return []+ else fmap (l:) getRest++{-+response :: BSStream s => s -> IO (Response, ByteString)+response st =+ do reply <- bsGetLine st+-- reply <- fmap strip $ bsGetLine st+ if (BS.pack "+OK") `BS.isPrefixOf` reply+ then return (Ok, BS.drop 4 reply)+ else return (Err, BS.drop 5 reply)++-- | parse mutiline of response++-- do reply <- fmap strip $ bsGetLine st+responseML :: BSStream s => s -> IO (Response, ByteString)+responseML st =+ do reply <- bsGetLine st+ if (BS.pack "+OK") `BS.isPrefixOf` reply+ then do rest <- getRest+ return (Ok, BS.unlines (BS.drop 4 reply : rest))+ else return (Err, BS.drop 5 reply)+-- where getRest = do l <- fmap strip $ bsGetLine st+-- if l == BS.singleton '.'+ where getRest = do l <- bsGetLine st+ if BS.null l+ then return []+ else fmap (l:) getRest+-}++-- | sendCommand sends a pop3 command via a pop3 connection. This+-- action is too generic. Use more specific actions+sendCommand :: BSStream s => POP3Connection s -> Command -> IO (Response, ByteString)+sendCommand (POP3C conn _) (LIST Nothing) =+ bsPutCrLf conn (BS.pack "LIST") >> responseML conn+sendCommand (POP3C conn _) (UIDL Nothing) =+ bsPutCrLf conn (BS.pack "UIDL") >> responseML conn+sendCommand (POP3C conn _) (RETR msg) =+ bsPutCrLf conn (BS.pack $ "RETR " ++ show msg) >> responseML conn+sendCommand (POP3C conn _) (TOP msg n) =+ bsPutCrLf conn (BS.pack $ "TOP " ++ show msg ++ " " ++ show n) >> responseML conn+sendCommand (POP3C conn _) (AUTH LOGIN user pass) =+ do bsPutCrLf conn $ BS.pack "AUTH LOGIN"+ bsGetLine conn+ bsPutCrLf conn $ BS.pack userB64+ bsGetLine conn+ bsPutCrLf conn $ BS.pack passB64+ response conn+ where (userB64, passB64) = A.login user pass+sendCommand (POP3C conn _) (AUTH at user pass) =+ do bsPutCrLf conn $ BS.pack $ unwords ["AUTH", show at]+ c <- bsGetLine conn+ let challenge =+ if BS.take 2 c == BS.pack "+ "+ then b64Decode $ BS.unpack $ head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c+ else ""+ bsPutCrLf conn $ BS.pack $ A.auth at challenge user pass+ response conn+sendCommand (POP3C conn msg_id) command =+ bsPutCrLf conn (BS.pack commandStr) >> response conn+ where commandStr = case command of+ (USER name) -> "USER " ++ name+ (PASS pass) -> "PASS " ++ pass+ NOOP -> "NOOP"+ QUIT -> "QUIT"+ STAT -> "STAT"+ (DELE msg) -> "DELE " ++ show msg+ RSET -> "RSET"+ (LIST msg) -> "LIST " ++ maybe "" show msg+ (UIDL msg) -> "UIDL " ++ maybe "" show msg+ (APOP user pass) -> "APOP " ++ user ++ " " ++ hexDigest (msg_id ++ pass)++user :: BSStream s => POP3Connection s -> String -> IO ()+user conn name = do (resp, _) <- sendCommand conn (USER name)+ when (resp == Err) $ fail "cannot send user name"++pass :: BSStream s => POP3Connection s -> String -> IO ()+pass conn pwd = do (resp, _) <- sendCommand conn (PASS pwd)+ when (resp == Err) $ fail "cannot send password"++userPass :: BSStream s => POP3Connection s -> UserName -> Password -> IO ()+userPass conn name pwd = user conn name >> pass conn pwd++auth :: BSStream s => POP3Connection s -> AuthType -> UserName -> Password -> IO ()+auth conn at user pass =+ do (resp, msg) <- sendCommand conn (AUTH at user pass)+ unless (resp == Ok) $ fail $ "authentication failed: " ++ BS.unpack msg+ ++apop :: BSStream s => POP3Connection s -> String -> String -> IO ()+apop conn name pwd =+ do (resp, msg) <- sendCommand conn (APOP name pwd)+ when (resp == Err) $ fail $ "authentication failed: " ++ BS.unpack msg++stat :: BSStream s => POP3Connection s -> IO (Int, Int)+stat conn = do (resp, msg) <- sendCommand conn STAT+ when (resp == Err) $ fail "cannot get stat info"+ let (nn, mm) = BS.span (/=' ') msg+ return (read $ BS.unpack nn, read $ BS.unpack $ BS.tail mm)++dele :: BSStream s => POP3Connection s -> Int -> IO ()+dele conn n = do (resp, _) <- sendCommand conn (DELE n)+ when (resp == Err) $ fail "cannot delete"++retr :: BSStream s => POP3Connection s -> Int -> IO ByteString+retr conn n = do (resp, msg) <- sendCommand conn (RETR n)+ when (resp == Err) $ fail "cannot retrieve"+ return $ BS.tail $ BS.dropWhile (/='\n') msg++top :: BSStream s => POP3Connection s -> Int -> Int -> IO ByteString+top conn n m = do (resp, msg) <- sendCommand conn (TOP n m)+ when (resp == Err) $ fail "cannot retrieve"+ return $ BS.tail $ BS.dropWhile (/='\n') msg++rset :: BSStream s => POP3Connection s -> IO ()+rset conn = do (resp, _) <- sendCommand conn RSET+ when (resp == Err) $ fail "cannot reset"++allList :: BSStream s => POP3Connection s -> IO [(Int, Int)]+allList conn = do (resp, lst) <- sendCommand conn (LIST Nothing)+ when (resp == Err) $ fail "cannot retrieve the list"+ return $ map f $ tail $ BS.lines lst+ where f s = let (n1, n2) = BS.span (/=' ') s+ in (read $ BS.unpack n1, read $ BS.unpack $ BS.tail n2)++list :: BSStream s => POP3Connection s -> Int -> IO Int+list conn n = do (resp, lst) <- sendCommand conn (LIST (Just n))+ when (resp == Err) $ fail "cannot retrieve the list"+ let (_, n2) = BS.span (/=' ') lst+ return $ read $ BS.unpack $ BS.tail n2++allUIDLs :: BSStream s => POP3Connection s -> IO [(Int, ByteString)]+allUIDLs conn = do (resp, lst) <- sendCommand conn (UIDL Nothing)+ when (resp == Err) $ fail "cannot retrieve the uidl list"+ return $ map f $ tail $ BS.lines lst+ where f s = let (n1, n2) = BS.span (/=' ') s in (read $ BS.unpack n1, n2)++uidl :: BSStream s => POP3Connection s -> Int -> IO ByteString+uidl conn n = do (resp, msg) <- sendCommand conn (UIDL (Just n))+ when (resp == Err) $ fail "cannot retrieve the uidl data"+ return $ BS.tail $ BS.dropWhile (/=' ') msg++closePop3 :: BSStream s => POP3Connection s -> IO ()+closePop3 c@(POP3C conn _) = do sendCommand c QUIT+ bsClose conn++doPop3Port :: String -> PortNumber -> (POP3Connection Handle -> IO a) -> IO a+doPop3Port host port execution =+ bracket (connectPop3Port host port) closePop3 execution++doPop3 :: String -> (POP3Connection Handle -> IO a) -> IO a+doPop3 host execution = doPop3Port host 110 execution++doPop3Stream :: BSStream s => s -> (POP3Connection s -> IO b) -> IO b+doPop3Stream conn execution = bracket (connectStream conn) closePop3 execution
+ HaskellNet/SMTP.hs view
@@ -0,0 +1,249 @@+----------------------------------------------------------------------+-- |+-- Module : HaskellNet.SMTP+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : stable+-- Portability : portable+-- +-- SMTP client implementation+-- ++module HaskellNet.SMTP+ ( -- * Types+ Command(..)+ , Response(..)+ , SMTPConnection+ -- * Establishing Connection+ , connectSMTPPort+ , connectSMTP+ , connectStream+ -- * Operation to a Connection+ , sendCommand+ , closeSMTP+ -- * Other Useful Operations + , sendMail+ , doSMTPPort+ , doSMTP+ , doSMTPStream+ )+ where++import HaskellNet.BSStream+import Data.ByteString (ByteString, append)+import qualified Data.ByteString.Char8 as BS+import Network.BSD (getHostName)+import Network++import Control.Exception+import Control.Monad (unless)++import Data.List (intersperse)+import Data.Char (chr, ord, isSpace, isDigit)++import HaskellNet.Auth++import System.IO++import Prelude hiding (catch)++data (BSStream s) => SMTPConnection s = SMTPC !s ![ByteString]++data Command = HELO String+ | EHLO String+ | MAIL String+ | RCPT String+ | DATA ByteString+ | EXPN String+ | VRFY String+ | HELP String+ | AUTH AuthType UserName Password + | NOOP+ | RSET+ | QUIT+ deriving (Show, Eq)++type ReplyCode = Int++data Response = Ok+ | SystemStatus+ | HelpMessage+ | ServiceReady+ | ServiceClosing+ | UserNotLocal+ | CannotVerify+ | StartMailInput+ | ServiceNotAvailable+ | MailboxUnavailable+ | ErrorInProcessing+ | InsufficientSystemStorage+ | SyntaxError+ | ParameterError+ | CommandNotImplemented+ | BadSequence+ | ParameterNotImplemented+ | MailboxUnavailableError+ | UserNotLocalError+ | ExceededStorage+ | MailboxNotAllowed+ | TransactionFailed+ deriving (Show, Eq)++codeToResponse :: Num a => a -> Response+codeToResponse 211 = SystemStatus+codeToResponse 214 = HelpMessage+codeToResponse 220 = ServiceReady+codeToResponse 221 = ServiceClosing+codeToResponse 250 = Ok+codeToResponse 251 = UserNotLocal+codeToResponse 252 = CannotVerify+codeToResponse 354 = StartMailInput+codeToResponse 421 = ServiceNotAvailable+codeToResponse 450 = MailboxUnavailable+codeToResponse 451 = ErrorInProcessing+codeToResponse 452 = InsufficientSystemStorage+codeToResponse 500 = SyntaxError+codeToResponse 501 = ParameterError+codeToResponse 502 = CommandNotImplemented+codeToResponse 503 = BadSequence+codeToResponse 504 = ParameterNotImplemented+codeToResponse 550 = MailboxUnavailableError+codeToResponse 551 = UserNotLocalError+codeToResponse 552 = ExceededStorage+codeToResponse 553 = MailboxNotAllowed+codeToResponse 554 = TransactionFailed++crlf = BS.pack "\r\n"++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False++-- | connecting SMTP server with the specified name and port number.+connectSMTPPort :: String -- ^ name of the server+ -> PortNumber -- ^ port number+ -> IO (SMTPConnection Handle)+connectSMTPPort hostname port = connectTo hostname (PortNumber port) >>= connectStream++-- | connecting SMTP server with the specified name and port 25.+connectSMTP :: String -- ^ name of the server+ -> IO (SMTPConnection Handle)+connectSMTP = flip connectSMTPPort 25++-- | create SMTPConnection from already connected Stream+connectStream :: BSStream s => s -> IO (SMTPConnection s)+connectStream st = + do (code, msg) <- parseResponse st+ unless (code == 220) $+ do bsClose st+ fail "cannot connect to the server"+ senderHost <- getHostName+ (code, msg) <- sendCommand (SMTPC st []) (EHLO senderHost) + unless (code == 250) $+ do (code, msg) <- sendCommand (SMTPC st []) (HELO senderHost)+ unless (code == 250) $+ do bsClose st+ fail "cannot connect to the server"+ return (SMTPC st (tail $ BS.lines msg))++parseResponse :: BSStream s => s -> IO (ReplyCode, ByteString)+parseResponse st = + do (code, bdy) <- readLines+ return (read $ BS.unpack code, BS.unlines bdy)+ where readLines =+ do l <- bsGetLine st+ let (c, bdy) = BS.span isDigit l+ if not (BS.null bdy) && BS.head bdy == '-'+ then do (c, ls) <- readLines+ return (c, (BS.tail bdy:ls))+ else return (c, [BS.tail bdy])+++-- | send a method to a server+sendCommand :: BSStream s => SMTPConnection s -> Command -> IO (ReplyCode, ByteString)+sendCommand (SMTPC conn _) (DATA dat) =+ do bsPutCrLf conn $ BS.pack "DATA"+ (code, msg) <- parseResponse conn+ unless (code == 354) $ fail "this server cannot accept any data."+ mapM_ sendLine $ BS.lines dat ++ [BS.pack "."]+ parseResponse conn+ where sendLine l = bsPutCrLf conn l+sendCommand (SMTPC conn _) (AUTH LOGIN username password) =+ do bsPutCrLf conn command+ (code, msg) <- parseResponse conn+ bsPutCrLf conn $ BS.pack userB64+ (code, msg) <- parseResponse conn+ bsPutCrLf conn $ BS.pack passB64+ parseResponse conn+ where command = BS.pack $ "AUTH LOGIN"+ (userB64, passB64) = login username password+sendCommand (SMTPC conn _) (AUTH at username password) =+ do bsPutCrLf conn command+ (code, msg) <- parseResponse conn+ unless (code == 334) $ fail "authentication failed."+ bsPutCrLf conn $ BS.pack $ auth at (BS.unpack msg) username password+ parseResponse conn+ where command = BS.pack $ unwords ["AUTH", show at]+sendCommand (SMTPC conn _) meth =+ do bsPutCrLf conn $ BS.pack command+ parseResponse conn+ where command = case meth of+ (HELO param) -> "HELO " ++ param+ (EHLO param) -> "EHLO " ++ param+ (MAIL param) -> "MAIL FROM:<" ++ param ++ ">"+ (RCPT param) -> "RCPT TO:<" ++ param ++ ">"+ (EXPN param) -> "EXPN " ++ param+ (VRFY param) -> "VRFY " ++ param+ (HELP msg) -> if null msg+ then "HELP\r\n"+ else "HELP " ++ msg+ NOOP -> "NOOP"+ RSET -> "RSET"+ QUIT -> "QUIT"++-- | +-- close the connection. This function send the QUIT method, so you+-- do not have to QUIT method explicitly.+closeSMTP :: BSStream s => SMTPConnection s -> IO ()+closeSMTP c@(SMTPC conn _) = do sendCommand c QUIT+ bsClose conn++-- | +-- sending a mail to a server. This is achieved by sendMessage. If+-- something is wrong, it raises an IOexception.+sendMail :: BSStream s =>+ String -- ^ sender mail+ -> [String] -- ^ receivers+ -> ByteString -- ^ data+ -> SMTPConnection s+ -> IO ()+sendMail sender receivers dat conn =+ catcher `handle` mainProc+ where mainProc = do (250, _) <- sendCommand conn (MAIL sender)+ vals <- mapM (sendCommand conn . RCPT) receivers+ unless (all ((==250) . fst) vals) $ fail "sendMail error"+ (250, _) <- sendCommand conn (DATA dat)+ return ()+ catcher e@(PatternMatchFail _) = fail "sendMail error"+ catcher e = throwIO e++-- | +-- doSMTPPort open a connection, and do an IO action with the+-- connection, and then close it.+doSMTPPort :: String -> PortNumber -> (SMTPConnection Handle -> IO a) -> IO a+doSMTPPort host port execution =+ bracket (connectSMTPPort host port) closeSMTP execution++-- | +-- doSMTP is similar to doSMTPPort, except that it does not+-- require port number but connects to the server with port 25.+doSMTP :: String -> (SMTPConnection Handle -> IO a) -> IO a+doSMTP host execution = doSMTPPort host 25 execution++-- |+-- doSMTPStream is similar to doSMTPPort, except that its argument is+-- a Stream data instead of hostname and port number.+doSMTPStream :: BSStream s => s -> (SMTPConnection s -> IO a) -> IO a+doSMTPStream s execution = bracket (connectStream s) closeSMTP execution
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+--main = defaultMainWithHooks defaultUserHooks
+ Text/Atom.hs view
@@ -0,0 +1,643 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+----------------------------------------------------------------------+-- |+-- Module : Text.Atom+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : experimental+-- Portability : portable+-- +-- Atom Syndication format Parser/Printer Library using HaXml+-- ++module Text.Atom+ ( Text(..), EntryContent(..), stringContent, xhtmlContent, binaryContent, srcContent+ , Person, mkPerson+ , Feed, mkFeed, Entry, mkEntry+ , Category, mkCategory, Generator, mkGenerator, defaultGenerator+ , Link, LinkRelation(..), mkLink, selfLink+ , Attr, get, set, update, has, add, howMany, set', get', delete+ , AName(..), AUri(..), AEmail(..), AAuthor(..), ACategory(..)+ , AContributor(..), AGenerator(..), AIcon(..), AId(..), ALink(..)+ , ALogo(..), ARights(..), ASubtitle(..), ATitle(..), AUpdated(..)+ , AEntries(..), AContent(..), APublished(..), ASource(..), ASummary(..)+ , ATerm(..), AScheme(..), ALabel(..), AVersion(..), AHref(..), ARel(..)+ , AMediatype(..), AHreflang(..), ALength(..)+ , PERSON(..), CATEGORY(..), GENERATOR(..), LINK(..), FEED(..), ENTRY(..)+ )+where++import Data.Record+import Data.List (genericLength, nubBy, isPrefixOf)+import Data.Char (isSpace)+import Data.Maybe+import Control.Applicative hiding (many)+import Data.Foldable+import Data.Map (findWithDefault, insert, Map)+import qualified Data.Map as M+import Data.Monoid (Sum(..))+import Data.Time (formatTime)+import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), ZonedTime(..), TimeZone(..), minutesToTimeZone, utc)+import System.Locale (defaultTimeLocale)+import Data.Time.Calendar+import Text.XML.HaXml hiding (version)+import Text.XML.HaXml.Escape (xmlEscape, xmlUnEscape, mkXmlEscaper)+import qualified Text.XML.HaXml.Html.Pretty as P (content)+import Text.XML.HaXml.Xml2Haskell+import Text.PrettyPrint.HughesPJ (hcat)+import qualified Codec.Binary.Base64.String as B64 (encode, decode)++import Prelude hiding (foldr1, foldr, or, any, all, concatMap, concat, elem)++e2e :: (Enum a, Enum b) => a -> b+e2e = toEnum . fromEnum+b64Encode :: String -> String+b64Encode = map e2e . B64.encode . map e2e+b64Decode :: String -> String+b64Decode = map e2e . B64.decode . map e2e++atomEscaper = mkXmlEscaper [('<', "lt"), ('>', "gt"), ('&', "amp"), ('"', "quot")] (`elem` "<>\"")+xEscape :: [Content] -> [Content]+xEscape cs = let Elem _ _ cs' = xmlEscape atomEscaper (Elem "" [] cs) in cs'++xUnEscape :: [Content] -> [Content]+xUnEscape cs = let Elem _ _ cs' = xmlUnEscape atomEscaper (Elem "" [] cs) in cs'++escapeString :: String -> String+escapeString s = fromText' $ xEscape [CString False s]++unEscapeString :: String -> String+unEscapeString s = fromText' $ xUnEscape [CString False s]++------------------------------------------------------------+-- basic constructs ++data Text = Text String+ | HTML String+ | XHtml [Content]+instance Show Text where+ show (Text s) = "Text "++show s+ show (HTML s) = "HTML "++show s+ show (XHtml cont) = "XHtml \""++show (hcat (map P.content cont))++"\""++data EntryContent = TextCont Text+ | BinaryData String String+ | OtherSrc String String+ deriving Show+stringContent = TextCont . Text+xhtmlContent = TextCont . XHtml+binaryContent t d | typeChecker t = error "binary data must not text, html, or xhtml"+ | otherwise = BinaryData t d+srcContent t url | typeChecker t = error "other src must not text, html, or xhtml"+ | otherwise = OtherSrc t url+typeChecker t = any (flip isPrefixOf t) ["text", "html", "xhtml"]+++data Person = Person { personName :: !Text+ , personUri :: Maybe String+ , personEmail :: Maybe String+ } deriving Show+mkPerson :: String -> Person+mkPerson s = Person (Text s) Nothing Nothing++------------------------------------------------------------+-- atom types+data Feed = Feed { feedAuthor :: [Person]+ , feedCategory :: [Category]+ , feedContributor :: [Person]+ , feedGenerator :: [Generator]+ , feedIcon :: Maybe String+ , feedId :: !String+ , feedLink :: [Link]+ , feedLogo :: Maybe String+ , feedRights :: Maybe Text+ , feedSubtitle :: Maybe Text+ , feedTitle :: !Text+ , feedUpdated :: !ZonedTime+ , feedEntries :: [Entry]+ } deriving Show+mkFeed :: Person -- ^ primary author+ -> String -- ^ id+ -> String -- ^ self link+ -> String -- ^ title+ -> ZonedTime -> Feed+mkFeed a id l t ut = Feed [a] [] [] [defaultGenerator] Nothing id [selfLink l] Nothing Nothing Nothing (Text t) ut []++data Entry = Entry { entryAuthor :: [Person]+ , entryCategory :: [Category]+ , entryContent :: Maybe EntryContent+ , entryContributor :: [Person]+ , entryId :: !String+ , entryLink :: [Link]+ , entryPublished :: Maybe ZonedTime+ , entryRights :: Maybe Text+ , entrySource :: Maybe Feed+ , entrySummary :: Maybe String+ , entryTitle :: !Text+ , entryUpdated :: !ZonedTime+ } deriving Show+mkEntry :: String -- ^ id+ -> String -- ^ title+ -> EntryContent -- ^ content+ -> ZonedTime -> Entry+mkEntry id title content updated = Entry [] [] (Just content) [] id [] Nothing Nothing Nothing Nothing (Text title) updated++data Category = Category { categoryTerm :: !String+ , categoryScheme :: Maybe String+ , categoryLabel :: Maybe String+ } deriving Show+mkCategory :: String -> Category+mkCategory s = Category s Nothing Nothing++data Generator = Generator { generatorName :: !String+ , generatorUri :: Maybe String+ , generatorVersion :: Maybe String+ } deriving Show+mkGenerator :: String -> Generator+mkGenerator s = Generator s Nothing Nothing+defaultGenerator :: Generator+defaultGenerator = Generator "HaskellNet" (Just "http://darcs.haskell.org/SoC/haskellnet/") (Just "0.1")++data Link = Link { linkHref :: !String+ , linkRel :: !LinkRelation+ , linkMediatype :: Maybe String+ , linkHreflang :: Maybe String+ , linkTitle :: Maybe String+ , linkLength :: Maybe Integer+ } deriving Show+data LinkRelation = Alternate | Related | Self | Enclosure | Via deriving Eq+instance Show LinkRelation where+ show Alternate = "alternate"+ show Related = "related"+ show Self = "self"+ show Enclosure = "enclosure"+ show Via = "via"+instance Read LinkRelation where+ readsPrec d s = readParen (d > app_prec) (\s -> concatMap (f s) labels) s+ where app_prec = 10+ f s (s', l) | s' `isPrefixOf` s = [(l, drop (length s') s)]+ | otherwise = []+ labels = [ ("alternate", Alternate), ("related", Related)+ , ("self", Self), ("enclosure", Enclosure)+ , ("via", Via) ]+mkLink :: String -> Link+mkLink s = Link s Alternate Nothing Nothing Nothing Nothing+selfLink :: String -> Link+selfLink s = Link s Self Nothing Nothing Nothing Nothing++------------------------------------------------------------+-- field class/instance declarations++class AName r v | r -> v where name :: Attr r v+class AUri r v | r -> v where uri :: Attr r v+class AEmail r v | r -> v where email :: Attr r v+class AAuthor r v | r -> v where author :: Attr r v+class ACategory r v | r -> v where category :: Attr r v+class AContributor r v | r -> v where contributor :: Attr r v+class AGenerator r v | r -> v where generator :: Attr r v+class AIcon r v | r -> v where icon :: Attr r v+class AId r v | r -> v where identifier :: Attr r v+class ALink r v | r -> v where link :: Attr r v+class ALogo r v | r -> v where logo :: Attr r v+class ARights r v | r -> v where rights :: Attr r v+class ASubtitle r v | r -> v where subtitle :: Attr r v+class ATitle r v | r -> v where title :: Attr r v+class AUpdated r v | r -> v where updated :: Attr r v+class AEntries r v | r -> v where entries :: Attr r v+class AContent r v | r -> v where content :: Attr r v+class APublished r v | r -> v where published :: Attr r v+class ASource r v | r -> v where source :: Attr r v+class ASummary r v | r -> v where summary :: Attr r v+class ATerm r v | r -> v where term :: Attr r v+class AScheme r v | r -> v where scheme :: Attr r v+class ALabel r v | r -> v where label :: Attr r v+class AVersion r v | r -> v where version :: Attr r v+class AHref r v | r -> v where href :: Attr r v+class ARel r v | r -> v where rel :: Attr r v+class AMediatype r v | r -> v where mediatype :: Attr r v+class AHreflang r v | r -> v where hreflang :: Attr r v+class ALength r v | r -> v where len :: Attr r v+++instance AName Person Text where+ name = Attr personName setter+ where setter r v = r { personName = v }++instance AUri Person (Maybe String) where+ uri = Attr personUri setter+ where setter r v = r { personUri = v }++instance AEmail Person (Maybe String) where+ email = Attr personEmail setter+ where setter r v = r { personEmail = v }++instance AAuthor Feed [Person] where+ author = Attr feedAuthor setter+ where setter r v | check r v = r { feedAuthor = v }+ | otherwise = error "Feed must have at least one author"+ check r [] = not $ any (null . get author) $ feedEntries r+ check r vs = True++instance ACategory Feed [Category] where+ category = Attr feedCategory setter+ where setter r v = r { feedCategory = v }++instance AContributor Feed [Person] where+ contributor = Attr feedContributor setter+ where setter r v = r { feedContributor = v }++instance AGenerator Feed [Generator] where+ generator = Attr feedGenerator setter+ where setter r v = r { feedGenerator = v }++instance AIcon Feed (Maybe String) where+ icon = Attr feedIcon setter+ where setter r v = r { feedIcon = v }++instance AId Feed String where+ identifier = Attr feedId setter+ where setter r v = r { feedId = v }++instance ALink Feed [Link] where+ link = Attr feedLink setter+ where setter r v | check v = r { feedLink = v }+ | otherwise = error "links do not satisfy the specs of atom"+ check ls = let ls' = filter ((==Alternate) . get rel) ls+ ls'' = filter ((==Self) . get rel) ls+ in length (nubBy f1 ls') == length ls' && + not (null ls'')+ f1 a b = get mediatype a == get mediatype b && + get hreflang a == get hreflang b+ +instance ALogo Feed (Maybe String) where+ logo = Attr feedLogo setter+ where setter r v = r { feedLogo = v }++instance ARights Feed (Maybe Text) where+ rights = Attr feedRights setter+ where setter r v = r { feedRights = v }++instance ASubtitle Feed (Maybe Text) where+ subtitle = Attr feedSubtitle setter+ where setter r v = r { feedSubtitle = v }++instance ATitle Feed Text where+ title = Attr feedTitle setter+ where setter r v = r { feedTitle = v }++instance AUpdated Feed ZonedTime where+ updated = Attr feedUpdated setter+ where setter r v = r { feedUpdated = v }++instance AEntries Feed [Entry] where+ entries = Attr feedEntries setter+ where setter r v = r { feedEntries = v }+ ++instance AAuthor Entry [Person] where+ author = Attr entryAuthor setter+ where setter r v = r { entryAuthor = v }++instance ACategory Entry [Category] where+ category = Attr entryCategory setter+ where setter r v = r { entryCategory = v }++instance AContent Entry (Maybe EntryContent) where+ content = Attr entryContent setter+ where setter r v = r { entryContent = v }++instance AContributor Entry [Person] where+ contributor = Attr entryContributor setter+ where setter r v = r { entryContributor = v }++instance AId Entry String where+ identifier = Attr entryId setter+ where setter r v = r { entryId = v }++instance ALink Entry [Link] where+ link = Attr entryLink setter+ where setter r v | check r v = r { entryLink = v }+ | otherwise = error "links do not satisfy the specs of atom"+ check r ls = + let ls' = filter ((==Alternate) . get rel) ls+ in length (nubBy f1 ls') == length ls' && + (isJust (entryContent r) || not (null ls'))+ f1 a b = get mediatype a == get mediatype b && + get hreflang a == get hreflang b+++instance APublished Entry (Maybe ZonedTime) where+ published = Attr entryPublished setter+ where setter r v = r { entryPublished = v }++instance ARights Entry (Maybe Text) where+ rights = Attr entryRights setter+ where setter r v = r { entryRights = v }++instance ASource Entry (Maybe Feed) where+ source = Attr entrySource setter+ where setter r v = r { entrySource = fmap (delete entries) v }++instance ASummary Entry (Maybe String) where+ summary = Attr entrySummary setter+ where setter r Nothing | check (get content r) = error "summary is required to this entry"+ setter r v = r { entrySummary = v }+ check (Just (BinaryData _ _)) = True+ check (Just (OtherSrc _ _)) = True+ check _ = False++instance ATitle Entry Text where+ title = Attr entryTitle setter+ where setter r v = r { entryTitle = v }++instance AUpdated Entry ZonedTime where+ updated = Attr entryUpdated setter+ where setter r v = r { entryUpdated = v }++instance ATerm Category String where+ term = Attr categoryTerm setter+ where setter r v = r { categoryTerm = v }++instance AScheme Category (Maybe String) where+ scheme = Attr categoryScheme setter+ where setter r v = r { categoryScheme = v }++instance ALabel Category (Maybe String) where+ label = Attr categoryLabel setter+ where setter r v = r { categoryLabel = v }++instance AName Generator String where+ name = Attr generatorName setter+ where setter r v = r { generatorName = v }++instance AUri Generator (Maybe String) where+ uri = Attr generatorUri setter+ where setter r v = r { generatorUri = v }++instance AVersion Generator (Maybe String) where+ version = Attr generatorVersion setter+ where setter r v = r { generatorVersion = v }++instance AHref Link String where+ href = Attr linkHref setter+ where setter r v = r { linkHref = v }++instance ARel Link LinkRelation where+ rel = Attr linkRel setter+ where setter r v = r { linkRel = v }++instance AMediatype Link (Maybe String) where+ mediatype = Attr linkMediatype setter+ where setter r v = r { linkMediatype = v }++instance AHreflang Link (Maybe String) where+ hreflang = Attr linkHreflang setter+ where setter r v = r { linkHreflang = v }++instance ATitle Link (Maybe String) where+ title = Attr linkTitle setter+ where setter r v = r { linkTitle = v }++instance ALength Link (Maybe Integer) where+ len = Attr linkLength setter+ where setter r v = r { linkLength = v }++------------------------------------------------------------+-- XML <-> ATOM data types interchange++class (AName r Text, AUri r (Maybe String), AEmail r (Maybe String)) + => PERSON r+instance PERSON Person+class (ATerm r String, AScheme r (Maybe String), ALabel r (Maybe String))+ => CATEGORY r+instance CATEGORY Category+class (AName r String, AUri r (Maybe String), AVersion r (Maybe String))+ => GENERATOR r+instance GENERATOR Generator+class ( AHref r String, ARel r LinkRelation, AMediatype r (Maybe String)+ , AHreflang r (Maybe String), ATitle r (Maybe String)+ , ALength r (Maybe Integer))+ => LINK r+instance LINK Link++class ( AAuthor r [Person], ACategory r [Category], AContributor r [Person]+ , AGenerator r [Generator], AIcon r (Maybe String), AId r String+ , ALink r [Link], ALogo r (Maybe String), ARights r (Maybe Text)+ , ASubtitle r (Maybe Text), ATitle r Text, AUpdated r ZonedTime)+ => FEED r+instance FEED Feed+class ( AAuthor r [Person], ACategory r [Category]+ , AContent r (Maybe EntryContent), AContributor r [Person], AId r String+ , ALink r [Link], APublished r (Maybe ZonedTime), ARights r (Maybe Text)+ , ASource r (Maybe Feed), ASummary r (Maybe String)+ , ATitle r Text, AUpdated r ZonedTime)+ => ENTRY r+instance ENTRY Entry++s2cont :: String -> Content+s2cont s = CString False (escapeString s)++simpleCont :: String -> [Content] -> Content+simpleCont t cs = CElem $ Elem t [] cs++p2cont :: String -> Person -> Content+p2cont t p = simpleCont t (n:(u++m))+ where n = t2cont "name" $ get name p+ u = toList $ fmap (\u -> simpleCont "uri" [s2cont u]) $ get uri p+ m = toList $ fmap (\m -> simpleCont "email" [s2cont m]) $ get email p+cont2p :: Content -> Person+cont2p (CElem (Elem _ _ cs)) = Person n u m+ where n = cont2t $ head $ getTags "name" cs+ u = fmap fromText' $ listToMaybe $ getChildren "uri" cs+ m = fmap fromText' $ listToMaybe $ getChildren "email" cs++t2cont :: String -> Text -> Content+t2cont t (Text s) = CElem $ Elem t [("type", str2attr "text")] [s2cont s]+t2cont t (HTML s) = CElem $ Elem t [("type", str2attr "html")] [s2cont s]+t2cont t (XHtml cont) = CElem $ Elem t [("type", str2attr "xhtml")] [CElem $ Elem "div" [("xmlns", str2attr "http://www.w3.org/1999/xhtml")] cont]++cont2t :: Content -> Text+cont2t (CElem (Elem _ ats cs)) =+ case typ of+ Just t | t == "html" || t == "text/html" -> HTML contText+ | t == "xhtml" || t == "text/xhtml" -> XHtml cont+ _ -> Text contText + where typ = possibleA fromAttrToStr "type" ats+ contText = fromText' $ xUnEscape cs+ cont = stripSpaces `o` children $ head cs++zt2cont :: String -> ZonedTime -> Content+zt2cont t (ZonedTime d (TimeZone diffs _ _))+ = simpleCont t [s2cont $ formatTime defaultTimeLocale "%FT%T" d ++ zs ]+ where zs = if diffs == 0 then "Z"+ else let (zh,zm) = diffs `divMod` 60+ (zh',zm') = if diffs < 0 && zm /= 0 + then (zh+1,60-zm) else (zh,zm)+ sig = if zh' < 0 then '-' else '+'+ in sig : show2 zh' ++ ":" ++ show2 zm'+ show2 n | abs n < 10 = '0':show (abs n)+ | otherwise = show n+++breaks :: Char -> String -> [String]+breaks c s = case rest of+ [] -> [s1]+ (_:s') -> s1:breaks c s'+ where (s1, rest) = break (==c) s++s2zt :: String -> ZonedTime+s2zt s = let (d, _:h') = break (=='T') s+ (h, z) = break (`elem` "+-Z") h'+ (year:mon:day:_) = breaks '-' d+ (hour:min:sec:_) = breaks ':' h+ zone = case z of+ "Z" -> utc+ zs@(_:_) -> + let (zh:zm:_) = map read $ breaks ':' zs+ in minutesToTimeZone ((abs zh * 60 + zm) * signum zh)+ _ -> utc+ in ZonedTime (LocalTime (fromGregorian (read year) (read mon) (read day))+ (TimeOfDay (read hour) (read min) (fromRational $ toRational (read sec::Double))))+ zone++fromMany :: (XmlContent a) => [Content] -> [a]+fromMany = fst . many fromElem++fromText' :: [Content] -> String+fromText' = concat . fst . many fromText++getTags :: String -> [Content] -> [Content]+getTags s = concatMap (tag s)++getChildren :: String -> [Content] -> [[Content]]+getChildren s = dropWhile null . map (tag s /> keep)++stripSpaces :: CFilter+stripSpaces = foldXml (ifTxt (\s -> if all isSpace s then none else keep) keep)++instance XmlContent Category where+ fromElem css@(CElem (Elem "category" ats cs):rest) = + case lookup "term" ats of+ Just v -> (Just (Category (attr2str v) s l), rest)+ Nothing -> (Nothing, css)+ where s = possibleA fromAttrToStr "scheme" ats+ l = possibleA fromAttrToStr "label" ats+ fromElem css = (Nothing, css)+ toElem c = [CElem (Elem "category" (catMaybes [t, s, l]) [])]+ where t = Just ("term", str2attr $ get term c)+ s = get scheme c >>= return . (,) "scheme" . str2attr+ l = get label c >>= return . (,) "label" . str2attr+instance XmlContent Generator where+ fromElem (CElem (Elem "generator" ats cs):rest) = + (Just (Generator n u v), rest)+ where n = fromText' cs+ u = possibleA fromAttrToStr "uri" ats+ v = possibleA fromAttrToStr "version" ats+ fromElem cs = (Nothing, cs)+ toElem g = [CElem $ Elem "generator" (catMaybes [u, v])+ [s2cont $ get name g]]+ where u = get uri g >>= Just . (,) "uri" . str2attr+ v = get version g >>= Just . (,) "version" . str2attr+instance XmlContent Link where+ fromElem (CElem (Elem "link" ats cs):rest) =+ (Just (Link hr r t hl ti len), rest)+ where hr = case possibleA fromAttrToStr "href" ats of+ Nothing -> error "link requires href attribute"+ Just v -> v+ r = maybe Alternate read $ possibleA fromAttrToStr "rel" ats+ t = possibleA fromAttrToStr "type" ats+ hl = possibleA fromAttrToStr "hreflang" ats+ ti = possibleA fromAttrToStr "title" ats+ len = fmap read $ possibleA fromAttrToStr "length" ats+ fromElem cs = (Nothing, cs)+ toElem l = [CElem $ Elem "link" (hr:r:catMaybes [t,hl,ti,len']) []]+ where hr = ("href", str2attr $ get href l)+ r = ("rel", str2attr $ show $ get rel l)+ t = get mediatype l >>= return . (,) "type" . str2attr+ hl = get hreflang l >>= return . (,) "hreflang" . str2attr+ ti = get title l >>= return . (,) "title" . str2attr+ len' = get len l >>= return . (,) "length" . str2attr . show+instance XmlContent EntryContent where+ fromElem (CElem (Elem "content" ats cs):rest) = + case possibleA fromAttrToStr "type" ats of+ Just "text" -> (Just $ TextCont $ Text inText, rest)+ Just "html" -> (Just $ TextCont $ HTML inText, rest)+ Just "xhtml" -> (Just $ TextCont $ XHtml inHtml, rest)+ Just "text/html" -> (Just $ TextCont $ HTML inText, rest)+ Just "text/xhtml" -> (Just $ TextCont $ XHtml inHtml, rest)+ Just s | "text" `isPrefixOf` s -> + (Just $ TextCont $ Text inText, rest)+ | otherwise -> case src of+ Just d -> (Just $ OtherSrc s d, rest)+ Nothing -> (Just $ BinaryData s $ b64Decode inText, rest)+ where inText = fromText' cs+ inHtml = concatMap stripSpaces $ head $ getChildren "div" $ cs+ src = possibleA fromAttrToStr "src" ats+ fromElem cs = (Nothing, cs)+ toElem (TextCont (Text s)) = [CElem $ Elem "content" [("type", str2attr "text")] [s2cont s]]+ toElem (TextCont (HTML s)) = [CElem $ Elem "content" [("type", str2attr "html")] [s2cont s]]+ toElem (TextCont (XHtml cont)) = [CElem $ Elem "content" [("type", str2attr "xhtml")] [CElem $ Elem "div" [("xmlns", str2attr "http://www.w3.org/1999/xhtml")] cont]]+ toElem (BinaryData t d) = [CElem $ Elem "content" [("type", str2attr t)] [CString False (b64Encode d)]]+ toElem (OtherSrc t d) = [CElem $ Elem "content" [ ("type", str2attr t), ("src", str2attr t)] []]+instance XmlContent Entry where+ fromElem (CElem (Elem "entry" _ cs):rest) =+ (Just $ Entry authors cats content conts ident links pubd rts src summ tit upd, rest)+ where authors = map cont2p $ getTags "author" cs+ cats = fromMany $ getTags "category" cs+ content = listToMaybe $ fromMany $ getTags "content" cs+ conts = map cont2p $ getTags "contributor" cs+ ident = fromText' $ head $ getChildren "id" cs+ links = fromMany $ getTags "link" cs+ pubd = fmap (s2zt . fromText') $ listToMaybe $ getChildren "published" cs+ rts = fmap cont2t $ listToMaybe $ getTags "rights" cs+ src = (listToMaybe $ getChildren "source" cs) >>= fst . fromElem+ summ = fmap fromText' $ listToMaybe $ getChildren "summary" cs+ tit = cont2t $ head $ getTags "title" cs+ upd = s2zt $ fromText' $ head $ getChildren "updated" cs+ fromElem rest = (Nothing, rest)+ toElem e = [CElem $ Elem "entry" [] (concat [authors, cats, contents, conts, ident, links, pubd, rts, src, summ, tit, upd])]+ where authors = map (p2cont "author") $ get author e+ cats = toElem $ get category e+ contents = toElem $ get content e+ conts = map (p2cont "contributor") $ get contributor e+ ident = [simpleCont "id" [s2cont $ get identifier e]]+ links = toElem $ get link e+ pubd = toList $ fmap (zt2cont "published") $ get published e+ rts = toList $ fmap (t2cont "rights") $ get rights e+ src = toList $ fmap (\s -> CElem (Elem "source" [] (toElem s))) $ get source e + summ = toList $ fmap (\s -> simpleCont "summary" [s2cont s]) $ get summary e+ tit = [t2cont "title" $ get title e]+ upd = [zt2cont "updated" $ get updated e]+instance XmlContent Feed where+ fromElem (CElem (Elem "feed" _ cs):rest) = + (Just $ Feed authors cats conts gens ic ident links lg rts subtit tit upd ents, rest)+ where authors = map cont2p $ getTags "author" cs+ cats = fromMany $ getTags "category" cs+ conts = map cont2p $ getTags "contributor" cs+ gens = fromMany $ getTags "generator" cs+ ic = fmap fromText' $ listToMaybe $ getChildren "icon" cs+ ident = fromText' $ head $ getChildren "id" cs+ links = fromMany $ getTags "link" cs+ lg = fmap fromText' $ listToMaybe $ getChildren "logo" cs+ rts = fmap cont2t $ listToMaybe $ getTags "rights" cs+ subtit = fmap cont2t $ listToMaybe $ getTags "subtitle" cs+ tit = cont2t $ head $ getTags "title" cs+ upd = s2zt $ fromText' $ head $ getChildren "updated" cs+ ents = fromMany $ getTags "entry" cs+ fromElem rest = (Nothing, rest)+ toElem f = [CElem $ Elem "feed" [("xmlns", str2attr "http://www.w3.org/2005/Atom")] (concat [authors, cats, conts, gens, ic, ident, links, lg, rts, subtit, tit, upd, ents])]+ where authors = map (p2cont "author") $ get author f+ cats = toElem $ get category f+ conts = map (p2cont "contributor") $ get contributor f+ gens = toElem $ get generator f+ ic = toList $ fmap (\i -> simpleCont "icon" [s2cont i]) $ get icon f+ ident = [simpleCont "id" [s2cont $ get identifier f]]+ links = toElem $ get link f+ lg = toList $ fmap (\l -> simpleCont "logo" [s2cont l]) $ get logo f+ rts = toList $ fmap (t2cont "rights") $ get rights f+ subtit = toList $ fmap (t2cont "subtitle") $ get subtitle f+ tit = [t2cont "title" $ get title f]+ upd = [zt2cont "updated" $ get updated f]+ ents = toElem $ feedEntries f
+ Text/Bencode.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fallow-incoherent-instances #-}+----------------------------------------------------------------------+-- |+-- Module : Text.Bencode+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : experimental+-- Portability : GHC-only+-- +-- Bencode Parser and Serializer and type classes, for BitTorrent.+-- ++module Text.Bencode+ ( -- * Basic Type and Type Class+ Bencodable(..), BencodeNode(..)+ , parse, parses, encode+ )+where++import Data.Char (isDigit)+import Data.Map (Map, toList, fromList)+import qualified Data.Map as M (empty, insert, map, mapKeys, singleton)+import Data.Word+import Data.ByteString.Char8 (ByteString, pack, unpack)+import qualified Data.ByteString.Char8 as BS+import Control.Monad.Writer++class Bencodable a where+ fromBencode :: BencodeNode -> a+ toBencode :: a -> BencodeNode+ bRead :: String -> a+ bShow :: a -> String+ bRead = fromBencode . parse . pack+ bShow = unpack . encode . toBencode++instance Bencodable BencodeNode where+ fromBencode = id+ toBencode = id++instance Bencodable String where+ fromBencode (String s) = unpack s+ fromBencode _ = error "type mismatch"+ toBencode = String . pack++instance Bencodable ByteString where+ fromBencode (String s) = s+ fromBencode _ = error "type mismatch"+ toBencode = String++instance Bencodable Integer where+ fromBencode (Number n) = n+ fromBencode _ = error "type mismatch"+ toBencode = Number++instance Bencodable Int where+ fromBencode (Number n) = fromInteger n+ fromBencode _ = error "type mismatch"+ toBencode = Number . toInteger++instance (Bencodable a) => Bencodable (Map ByteString a) where+ fromBencode (Dictionary m) = M.map fromBencode m+ fromBencode _ = error "type mismatch"+ toBencode = Dictionary . M.map toBencode++instance (Bencodable a) => Bencodable [(ByteString, a)] where+ fromBencode (Dictionary m) = toList $ M.map fromBencode m+ fromBencode _ = error "type mismatch"+ toBencode = Dictionary . M.map toBencode . fromList++instance (Bencodable a) => Bencodable (Map String a) where+ fromBencode (Dictionary m) = M.mapKeys unpack $ M.map fromBencode m+ fromBencode _ = error "type mismatch"+ toBencode = Dictionary . M.map toBencode . M.mapKeys pack++instance (Bencodable a) => Bencodable [(String, a)] where+ fromBencode (Dictionary m) = toList $ M.mapKeys unpack $ M.map fromBencode m+ fromBencode _ = error "type mismatch"+ toBencode = Dictionary . M.mapKeys pack . M.map toBencode . fromList++instance (Bencodable a) => Bencodable [a] where+ fromBencode (List l) = map fromBencode l+ fromBencode _ = error "type mismatch"+ toBencode = List . map toBencode+++data BencodeNode = String !ByteString + | Number !Integer+ | Dictionary !(Map ByteString BencodeNode)+ | List [BencodeNode]+ deriving (Eq, Show)++stringP :: ByteString -> Writer [BencodeNode] ByteString+stringP s = if BS.head rest == ':' + then Writer (s', [String v]) else error "parse error for stringP"+ where (lenStr, rest) = BS.span isDigit s+ len = read $ unpack lenStr+ rest' = BS.tail rest+ (v, s') = BS.splitAt len rest'++numberP :: ByteString -> Writer [BencodeNode] ByteString+numberP s = Writer (BS.tail rest, [Number $ read $ unpack v])+ where (v, rest) = BS.break (=='e') s+ t = BS.head rest++headIsE = (=='e') . BS.head+untilM :: Monad m => (a -> Bool) -> (a -> m a) -> a -> m a+untilM c p s = if c s then return s else p s >>= untilM c p++listP :: ByteString -> Writer [BencodeNode] ByteString+listP s = fmap BS.tail $ censor f $ listP' s+ where listP' s = untilM headIsE bencodeP s+ f l = [List l]++censor' :: (Monoid w, Monoid w') => (w -> w') -> Writer w a -> Writer w' a+censor' f (Writer (a, w)) = Writer (a, f w)++dictP :: ByteString -> Writer [BencodeNode] ByteString+dictP s = fmap BS.tail $ censor' f $ dictP' s+ where dictP' s = + untilM headIsE (\s -> censor' l2n (stringP s >>= bencodeP)) s+ l2n [String k,v] = M.singleton k v+ f m = [Dictionary m]++bencodeP :: ByteString -> Writer [BencodeNode] ByteString+bencodeP s | isDigit h = stringP s+ | h == 'i' = numberP s'+ | h == 'l' = listP s'+ | h == 'd' = dictP s'+ | otherwise = error ("unidentified type specifier '"++[h]++"'")+ where s' = BS.tail s+ h = BS.head s++parse :: ByteString -> BencodeNode+parse = head . execWriter . bencodeP++parses :: ByteString -> [BencodeNode]+parses s = execWriter (parse' s)+ where parse' s = untilM BS.null bencodeP s++encode :: BencodeNode -> ByteString+encode (String s) = BS.concat [pack $ show $ BS.length s, colon, s]+encode (Number n) = BS.concat [i, pack $ show n, e]+encode (List lst) = BS.concat (l : (map encode lst) ++ [e])+encode (Dictionary dic) = BS.concat (d : concatMap f (toList dic) ++ [e])+ where f (k, v) = [encode $ String k, encode v]+colon = BS.singleton ':'+i = BS.singleton 'i'+l = BS.singleton 'l'+d = BS.singleton 'd'+e = BS.singleton 'e'
+ Text/IMAPParsers.hs view
@@ -0,0 +1,492 @@+----------------------------------------------------------------------+-- |+-- Module : Text.IMAPParsers+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : stable+-- Portability : portable+-- +-- Parsers for IMAP server responses+-- ++module Text.IMAPParsers where++import Text.Packrat.Parse hiding (space, spaces)+import Text.Packrat.Pos++import Data.Maybe+import Data.Word++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS++type Mailbox = String+type UID = Word64+type Charset = String+++data MailboxInfo = MboxInfo { _mailbox :: Mailbox+ , _exists :: Integer+ , _recent :: Integer+ , _flags :: [Flag]+ , _permanentFlags :: [Flag]+ , _isWritable :: Bool+ , _isFlagWritable :: Bool+ , _uidNext :: UID+ , _uidValidity :: UID+ }+ deriving (Show, Eq)+++data Flag = Seen+ | Answered+ | Flagged+ | Deleted+ | Draft+ | Recent+ | Keyword String+ deriving Eq++instance Show Flag where+ showsPrec d f = showParen (d > app_prec) $ showString $ showFlag f+ where app_prec = 10+ showFlag Seen = "\\Seen"+ showFlag Answered = "\\Answered"+ showFlag Flagged = "\\Flagged"+ showFlag Deleted = "\\Deleted"+ showFlag Draft = "\\Draft"+ showFlag Recent = "\\Recent"+ showFlag (Keyword s) = "\\" ++ s++data Attribute = Noinferiors+ | Noselect+ | Marked+ | Unmarked+ | OtherAttr String+ deriving (Show, Eq)++data MboxUpdate = MboxUpdate { exists :: Maybe Integer+ , recent :: Maybe Integer }+ deriving (Show, Eq)++data StatusCode = ALERT+ | BADCHARSET [Charset]+ | CAPABILITY_sc [String]+ | PARSE+ | PERMANENTFLAGS [Flag]+ | READ_ONLY+ | READ_WRITE+ | TRYCREATE+ | UIDNEXT_sc UID+ | UIDVALIDITY_sc UID+ | UNSEEN_sc Integer+ deriving (Eq, Show)++data ServerResponse = OK (Maybe StatusCode) String+ | NO (Maybe StatusCode) String+ | BAD (Maybe StatusCode) String+ | PREAUTH (Maybe StatusCode) String+ deriving (Eq, Show)+++-- | the query data type for the status command+data MailboxStatus = MESSAGES -- ^ the number of messages in the mailbox+ | RECENT -- ^ the number of messages with the \Recent flag set+ | UIDNEXT -- ^ the next unique identifier value of the mailbox+ | UIDVALIDITY -- ^ the unique identifier validity value of the mailbox+ deriving (Show, Read, Eq)+++++data RespDerivs =+ RespDerivs { dvFlags :: Result RespDerivs [Flag]+ , advTag :: Result RespDerivs String+ , advChar :: Result RespDerivs Char+ , advPos :: Pos+ }++instance Derivs RespDerivs where+ dvChar = advChar+ dvPos = advPos+++eval :: (RespDerivs -> Result RespDerivs r) -> String -> ByteString -> r+eval pMain tag s = case pMain (parse tag (Pos tag 1 1) s) of+ Parsed v d' e' -> v+ NoParse e -> error (show e)+++parse :: String -> Pos -> ByteString -> RespDerivs+parse tagstr pos s = d+ where d = RespDerivs flag tag chr pos+ flag = pParenFlags d+ tag = Parsed tagstr d (nullError d)+ chr = if BS.null s+ then NoParse (eofError d)+ else let (c, s') = (BS.head s, BS.tail s)+ in Parsed c (parse tagstr (nextPos pos c) s')+ (nullError d)++eval' :: (RespDerivs -> Result RespDerivs r) -> String -> String -> r+eval' pMain tag s = case pMain (parse' tag (Pos tag 1 1) s) of+ Parsed v d' e' -> v+ NoParse e -> error (show e)++parse' :: String -> Pos -> String -> RespDerivs+parse' tagstr pos s = d+ where d = RespDerivs flag tag chr pos+ flag = pParenFlags d+ tag = Parsed tagstr d (nullError d)+ chr = case s of+ (c:s') -> Parsed c (parse' tagstr (nextPos pos c) s')+ (nullError d)+ _ -> NoParse (eofError d)++mkMboxUpdate untagged = (MboxUpdate exists recent, others)+ where exists = lookup "EXISTS" $ catLefts untagged+ recent = lookup "RECENT" $ catLefts untagged+ others = catRights untagged++pNone :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, ())+Parser pNone =+ do untagged <- many pOtherLine+ resp <- Parser pDone+ let (mboxUp, _) = mkMboxUpdate untagged+ return (resp, mboxUp, ())++pCapability :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [String])+Parser pCapability =+ do untagged <- many (pCapabilityLine <|> pOtherLine)+ resp <- Parser pDone+ let (mboxUp, caps) = mkMboxUpdate untagged+ return (resp, mboxUp, concat caps)+ ++pList :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, Mailbox)])+Parser pList =+ do untagged <- many (pListLine "LIST" <|> pOtherLine)+ resp <- Parser pDone+ let (mboxUp, listRes) = mkMboxUpdate untagged+ return (resp, mboxUp, listRes)++pLsub :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, Mailbox)])+Parser pLsub =+ do untagged <- many (pListLine "LSUB" <|> pOtherLine)+ resp <- Parser pDone+ let (mboxUp, listRes) = mkMboxUpdate untagged+ return (resp, mboxUp, listRes)++pStatus :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(MailboxStatus, Integer)])+Parser pStatus =+ do untagged <- many (pStatusLine <|> pOtherLine)+ resp <- Parser pDone+ let (mboxUp, statRes) = mkMboxUpdate untagged+ return (resp, mboxUp, concat statRes)++pExpunge :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [Integer])+Parser pExpunge =+ do untagged <- many ((do string "* "+ n <- pExpungeLine+ return $ Right ("EXPUNGE", n))+ <|> pOtherLine)+ resp <- Parser pDone+ let (mboxUp, expunges) = mkMboxUpdate untagged+ return (resp, mboxUp, lookups "EXPUNGE" expunges)++pSearch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [UID])+Parser pSearch =+ do untagged <- many (pSearchLine <|> pOtherLine)+ resp <- Parser pDone+ let (mboxUp, searchRes) = mkMboxUpdate untagged + return (resp, mboxUp, concat searchRes)+++pSelect :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, MailboxInfo)+Parser pSelect =+ do untagged <- many (pSelectLine+ <|> (do string "* "+ anyChar `manyTill` crlfP+ return id))+ resp <- Parser pDone+ let box = case resp of+ OK writable _ ->+ emptyBox { _isWritable = isJust writable && fromJust writable == READ_WRITE }+ _ -> emptyBox+ return (resp, MboxUpdate Nothing Nothing, foldl (flip ($)) box untagged)+ where emptyBox = MboxInfo "" 0 0 [] [] False False 0 0++pFetch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(Integer, [(String, String)])])+Parser pFetch =+ do untagged <- many (pFetchLine <|> pOtherLine)+ resp <- Parser pDone+ let (mboxUp, fetchRes) = mkMboxUpdate untagged+ return (resp, mboxUp, fetchRes)+++pDone :: RespDerivs -> Result RespDerivs ServerResponse+Parser pDone = do tag <- Parser advTag+ string tag >> space+ respCode <- parseCode+ space+ stat <- optional (do s <- parseStatusCode+ space >> return s)+ body <- anyChar `manyTill` crlfP+ return $ respCode stat body+ where parseCode = choice $ [ string "OK" >> return OK+ , string "NO" >> return NO+ , string "BAD" >> return BAD+ , string "PREAUTH" >> return PREAUTH+ ]+ parseStatusCode =+ between (char '[') (char ']') $+ choice [ string "ALERT" >> return ALERT+ , do { string "BADCHARSET"+ ; ws <- optional parenWords+ ; return $ BADCHARSET $ fromMaybe [] ws }+ , do { string "CAPABILITY"+ ; space+ ; ws <- (many1 $ noneOf " ]") `sepBy1` space+ ; return $ CAPABILITY_sc ws }+ , string "PARSE" >> return PARSE+ , do { string "PERMANENTFLAGS" >> space >> char '('+ ; fs <- pFlag `sepBy1` spaces1+ ; char ')'+ ; return $ PERMANENTFLAGS fs }+ , string "READ-ONLY" >> return READ_ONLY+ , string "READ-WRITE" >> return READ_WRITE + , string "TRYCREATE" >> return TRYCREATE+ , do { string "UNSEEN" >> space+ ; num <- many1 digit+ ; return $ UNSEEN_sc $ read num }+ , do { string "UIDNEXT" >> space+ ; num <- many1 digit+ ; return $ UIDNEXT_sc $ read num }+ , do { string "UIDVALIDITY" >> space+ ; num <- many1 digit+ ; return $ UIDVALIDITY_sc $ read num }+ ]+ parenWords = between (space >> char '(') (char ')')+ (many1 (noneOf " )") `sepBy1` space)++++pFlag :: Parser RespDerivs Flag+pFlag = do char '\\'+ choice [ string "Seen" >> return Seen+ , string "Answered" >> return Answered+ , string "Flagged" >> return Flagged+ , string "Deleted" >> return Deleted+ , string "Draft" >> return Draft+ , string "Recent" >> return Recent+ , char '*' >> return (Keyword "*")+ , many1 atomChar >>= return . Keyword ]+ <|> (many1 atomChar >>= return . Keyword)++pParenFlags :: RespDerivs -> Result RespDerivs [Flag]+Parser pParenFlags = do char '('+ fs <- pFlag `sepBy` space+ char ')'+ return fs++atomChar :: Derivs d => Parser d Char+atomChar = noneOf " (){%*\"\\]"+++pNumberedLine :: String -> Parser RespDerivs Integer+pNumberedLine str = do num <- many1 digit+ space+ string str+ crlfP+ return $ read num++pExistsLine, pRecentLine, pExpungeLine :: Parser RespDerivs Integer+pExistsLine = pNumberedLine "EXISTS"+pRecentLine = pNumberedLine "RECENT"+pExpungeLine = pNumberedLine "EXPUNGE"+++pOtherLine :: Parser RespDerivs (Either (String, Integer) b)+pOtherLine = do string "* "+ choice [ pExistsLine >>= \n -> return (Left ("EXISTS", n))+ , pRecentLine >>= \n -> return (Left ("RECENT", n))+ , blankLine >> return (Left ("", 0))]+ where blankLine = anyChar `manyTill` crlfP+++pCapabilityLine :: Parser RespDerivs (Either a [String])+pCapabilityLine = do string "* CAPABILITY "+ ws <- many1 (noneOf " \r") `sepBy` space+ crlfP+ return $ Right ws+++pListLine :: String+ -> Parser RespDerivs (Either a ([Attribute], String, Mailbox))+pListLine list = + do string "* " >> string list >> space+ attrs <- parseAttrs+ sep <- parseSep+ mbox <- parseMailbox+ return $ Right (attrs, sep, mbox)+ where parseAttr =+ do char '\\'+ choice [ string "Noinferior" >> return Noinferiors+ , string "Noselect" >> return Noselect+ , string "Marked" >> return Marked+ , string "Unmarked" >> return Unmarked+ , many atomChar >>= return . OtherAttr+ ]+ parseAttrs = do char '('+ attrs <- parseAttr `sepBy` space+ char ')'+ return attrs+ parseSep = space >> char '"' >> anyChar `manyTill` char '"'+ parseMailbox = space >> anyChar `manyTill` crlfP+++pStatusLine :: Parser RespDerivs (Either a [(MailboxStatus, Integer)])+pStatusLine =+ do string "* STATUS "+ mbox <- anyChar `manyTill` space+ stats <- between (char '(') (char ')') (parseStat `sepBy1` space)+ crlfP+ return $ Right stats+ where parseStat =+ do cons <- choice [ string "MESSAGES" >>= return . read+ , string "RECENT" >>= return . read+ , string "UIDNEXT" >>= return . read+ , string "UIDVALIDITY" >>= return . read+ ]+ space+ num <- many1 digit >>= return . read+ return (cons, num)+++pSearchLine :: Parser RespDerivs (Either a [UID])+pSearchLine = do string "* SEARCH "+ nums <- (many1 digit) `sepBy` space+ crlfP+ return $ Right $ map read nums+++pSelectLine :: Parser RespDerivs (MailboxInfo -> MailboxInfo)+pSelectLine =+ do string "* "+ choice [ pExistsLine >>= \n -> return (\mbox -> mbox { _exists = n })+ , pRecentLine >>= \n -> return (\mbox -> mbox { _recent = n })+ , pFlags >>= \fs -> return (\mbox -> mbox { _flags = fs })+ , string "OK " >> okResps ]+ where pFlags = do string "FLAGS "+ char '('+ fs <- pFlag `sepBy` space+ char ')' >> crlfP+ return fs+ okResps =+ do char '['+ v <- choice [ do { string "UNSEEN "+ ; n <- many1 digit+ ; return $ id }+ , do { string "PERMANENTFLAGS ("+ ; fs <- pFlag `sepBy` space+ ; char ')'+ ; return $ \mbox ->+ mbox { _isFlagWritable = + Keyword "*" `elem` fs+ , _permanentFlags =+ filter (/= Keyword "*") fs } }+ , do { string "UIDNEXT "+ ; n <- many1 digit+ ; return $ \mbox ->+ mbox { _uidNext = read n } }+ , do { string "UIDVALIDITY "+ ; n <- many1 digit+ ; return $ \mbox ->+ mbox { _uidValidity = read n } }+ ]+ char ']'+ anyChar `manyTill` crlfP+ return v+++pFetchLine :: Parser RespDerivs (Either a (Integer, [(String, String)]))+pFetchLine =+ do string "* "+ num <- many1 digit+ string " FETCH" >> spaces+ char '('+ pairs <- pPair `sepBy` space+ char ')'+ crlfP+ return $ Right $ (read num, pairs)+ where pPair = do key <- anyChar `manyTill` space+ value <- (do char '('+ v <- pParen `sepBy` space+ char ')'+ return ("("++unwords v++")"))+ <|> (do char '{'+ num <- many1 digit >>= return . read+ char '}' >> crlfP+ sequence $ replicate num anyChar)+ <|> (do char '"'+ v <- noneOf "\"" `manyTill` char '"'+ return ("\""++v++"\""))+ <|> many1 atomChar+ return (key, value)+ pParen = (do char '"'+ v <- noneOf "\"" `manyTill` char '"'+ return ("\""++v++"\""))+ <|> (do char '('+ v <- pParen `sepBy` space+ char ')'+ return ("("++unwords v++")"))+ <|> (do char '\\'+ v <- many1 atomChar+ return ('\\':v))+ <|> many1 atomChar+++++----------------------------------------------------------------------+-- auxiliary parsers+space = char ' '+spaces = many space+spaces1 = many1 space++crlf :: String+crlf = "\r\n"++crlfP :: Derivs d => Parser d String+crlfP = string crlf++lookups :: Eq a => a -> [(a, b)] -> [b]+lookups _ [] = []+lookups k ((k', v):tl) | k == k' = v : lookups k tl+ | otherwise = lookups k tl++---- Either handling+catRights :: [Either a b] -> [b]+catRights [] = []+catRights (Right r:tl) = r : catRights tl+catRights (_:tl) = catRights tl++catLefts :: [Either a b] -> [a]+catLefts [] = []+catLefts (Left r:tl) = r : catLefts tl+catLefts (_:tl) = catLefts tl++isLeft, isRight :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False+isRight (Right _) = True+isRight _ = False++getLeft :: Either a b -> a+getLeft (Left l) = l+getLeft _ = error "not left"+getRight :: Either a b -> b+getRight (Right r) = r+getRight _ = error "not right"
+ Text/Mime.hs view
@@ -0,0 +1,343 @@+----------------------------------------------------------------------+-- |+-- Module : Text.Mime+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : experimental+-- Portability : portable+-- +-- Mime Parser+-- ++module Text.Mime where++import Text.Packrat.Parse hiding (space, spaces, Message)+import Text.Packrat.Pos++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS++import qualified Codec.Binary.Base64.String as B64 (encode, decode)+import Data.Digest.MD5 (hash)++import Data.Maybe+import Data.Char+import Data.List+import Data.Bits+import Data.Array++import qualified Text.PrettyPrint.HughesPJ as PP++data Mime = SinglePart [Header] ByteString+ | MultiPart [Header] [Mime]+ deriving (Eq, Show)++type Message = ([Header], ByteString)++type Header = (FieldName, FieldValue)+type FieldName = String+type FieldValue = String++data MimeDerivs =+ MimeDerivs { dvMessage :: Result MimeDerivs Message+ , dvMime :: Result MimeDerivs Mime+ , dvHeader :: Result MimeDerivs Header+ , dvRest :: Result MimeDerivs ByteString+ , advChar :: Result MimeDerivs Char+ , advPos :: Pos+ }+++instance Derivs MimeDerivs where+ dvChar = advChar+ dvPos = advPos+++mime :: ByteString -> Mime+mime = eval dvMime++message :: ByteString -> Message+message = eval dvMessage+++mime' :: String -> Mime+mime' = eval' dvMime++message' :: String -> Message+message' = eval' dvMessage++++eval :: (MimeDerivs -> Result MimeDerivs r) -> ByteString -> r+eval pMain s = case pMain (parse (Pos "<input>" 1 1) s) of+ Parsed v d' e' -> v+ NoParse e -> error (show e)++parse :: Pos -> ByteString -> MimeDerivs+parse pos s = d+ where d = MimeDerivs message mime header rest chr pos+ message = pMessage d+ mime = pMime d+ header = pHeader d+ rest = if BS.null s+ then NoParse (eofError d)+ else Parsed s (parse (BS.foldl nextPos pos s) BS.empty)+ (nullError d)+ chr = if BS.null s+ then NoParse (eofError d)+ else let (c, s') = (BS.head s, BS.tail s)+ in Parsed c (parse (nextPos pos c) s') (nullError d)++eval' :: (MimeDerivs -> Result MimeDerivs r) -> String -> r+eval' pMain s = case pMain (parse' (Pos "<input>" 1 1) s) of+ Parsed v d' e' -> v+ NoParse e -> error (show e)++parse' :: Pos -> String -> MimeDerivs+parse' pos s = d+ where d = MimeDerivs message mime header rest chr pos+ message = pMessage d+ mime = pMime d+ header = pHeader d+ rest = case s of+ "" -> NoParse (eofError d)+ _ -> Parsed (BS.pack s) (parse' (foldl nextPos pos s) "")+ (nullError d)+ chr = case s of+ (c:s') -> Parsed c (parse' (nextPos pos c) s') (nullError d)+ _ -> NoParse (eofError d)+++----------------------------------------------------------------------++lineBreak :: Derivs d => Parser d String+lineBreak = string "\r\n" <|> string "\n"++pHeader :: MimeDerivs -> Result MimeDerivs (String, String)+Parser pHeader =+ do field <- noneOf "\r\n" `manyTill` char ':'+ many (oneOf " \t")+ value <- noneOf "\r\n" `manyTill` lineBreak+ cont <- many (many1 (oneOf " \t") >> (anyChar `manyTill` lineBreak))+ return (capital field, unwords (value:cont))++pMessage :: MimeDerivs -> Result MimeDerivs Message+Parser pMessage = do headers <- many (Parser dvHeader)+ lineBreak+ body <- Parser dvRest+ return (headers, body)++pMime :: MimeDerivs -> Result MimeDerivs Mime+Parser pMime =+ do headers <- many (Parser dvHeader)+ lineBreak+ if isMultipart headers+ then let b = boundary headers+ in do string ("--"++b)+ lineBreak+ mimeBodies <- many $ mimeInner $ string ("--"++b)+ mimeLast <- mimeInner $ string ("--"++b++"--")+ return $ MultiPart headers (mimeBodies++[mimeLast])+ else do body <- Parser dvRest+ return $ SinglePart headers body+ where isMultipart headers =+ case lookup "Content-Type" headers of+ Nothing -> False+ Just s -> "multipart/" == (take 10 s)+ boundary headers =+ case lookup "Content-Type" headers of+ Nothing -> fail ""+ Just s -> let s' = drop 9 $ head $+ dropWhile ((/="boundary=") . (take 9))+ (tails s)+ in if head s' == '"'+ then takeWhile (/='"') $ tail s'+ else takeWhile isAlphaNum s'+ mimeInner b =+ do headers <- many (Parser dvHeader)+ lineBreak+ if isMultipart headers+ then let b' = boundary headers+ in do string ("--"++b')+ lineBreak+ mimeBodies <- many $ mimeInner $+ string ("--"++b')+ mimeLast <- mimeInner $ string ("--"++b'++"--")+ b >> lineBreak+ return $ MultiPart headers+ (mimeBodies++[mimeLast])+ else do body <- (anyChar `manyTill` lineBreak) `manyTill`+ (b >> lineBreak)+ return $ SinglePart headers+ (BS.pack $ unlines body)++----------------------------------------------------------------------+-- RFC 2047 Mime Header Extentions Parser+-- ++type CharSet = String+data RFC2047Derivs =+ RFC2047Derivs { dvHeaderExts :: Result RFC2047Derivs [(CharSet, String)]+ , hdvChar :: Result RFC2047Derivs Char+ , hdvPos :: Pos+ }++instance Derivs RFC2047Derivs where+ dvChar = hdvChar+ dvPos = hdvPos++headerExts :: ByteString -> [(CharSet, String)]+headerExts s = case dvHeaderExts (p (Pos "<input>" 1 1) s) of+ Parsed v d' e' -> v+ NoParse e -> error (show e)+ where p pos s = d+ where d = RFC2047Derivs mstr chr pos+ mstr = pHeaderExts d+ chr = if BS.null s+ then NoParse (eofError d)+ else let (c, s') = (BS.head s, BS.tail s)+ in Parsed c (p (nextPos pos c) s')+ (nullError d)++headerExts' :: String -> [(CharSet, String)]+headerExts' = headerExts . BS.pack+++pHeaderExts :: RFC2047Derivs -> Result RFC2047Derivs [(CharSet, String)]+Parser pHeaderExts = (getRFC2047 <|> normalStr) `sepBy` (many $ oneOf " \t")+ where getRFC2047 =+ do string "=?"+ charset <- anyChar `manyTill` char '?'+ mechanism <- choice [char 'B', char 'b', char 'Q', char 'q']+ char '?'+ body <- if mechanism `elem` "bB"+ then decodeB64+ else decodeQuoted+ return (charset, body)+ normalStr :: Derivs d => Parser d (String, String)+ normalStr =+ do body <- many1 $ noneOf " \t"+ return ("", body)++decodeQuoted :: Derivs d => Parser d String+decodeQuoted = do cs <- many (quotedChar <|> noneOf "?")+ string "?="+ return cs+ where quotedChar = do char '='+ n1 <- hexChar+ n2 <- hexChar+ return $ chr $ n1 * 16 + n2+ hexChar = choice [ do { c <- oneOf ['0'..'9']+ ; return $ ord c - ord '0' }+ , do { c <- oneOf (['A'..'F']++['a'..'f'])+ ; return $ ord (toLower c) - ord 'a' + 10 }+ ]+ ++decodeB64 :: Derivs d => Parser d String+decodeB64 = do bodies <- many pQuartet+ string "?="+ return $ concat bodies+ where pQuartet = do a <- b64Chars+ b <- b64Chars+ c <- b64Chars+ d <- b64Chars+ return $ decodeChars (a,b,c,d)+ <|> do a <- b64Chars+ b <- b64Chars+ c <- b64Chars+ char '='+ return $ init $ decodeChars (a, b, c, 0)+ <|> do a <- b64Chars+ b <- b64Chars+ string "=="+ return [head $ decodeChars (a, b, 0, 0)]+ b64Chars =+ do many $ noneOf (['a'..'z']++['A'..'Z']++['0'..'9']++"+/?=")+ choice [ do { c <- oneOf ['a'..'z']+ ; return $ ord c - ord 'a' + 26 }+ , do { c <- oneOf ['A'..'Z']+ ; return $ ord c - ord 'A' }+ , do { c <- oneOf ['0'..'9']+ ; return $ ord c - ord '0' + 52 }+ , char '+' >> return 62+ , char '/' >> return 63+ ]+ decodeChars (a, b, c, d) =+ map chr [ n `shiftR` 16 .&. 0xff+ , n `shiftR` 8 .&. 0xff+ , n .&. 0xff]+ where n = a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d+++----------------------------------------------------------------------+-- Mime Documents Pretty printer+--++showHeader' :: Header -> PP.Doc+showHeader' (field, value) =+ (PP.text (capital field) PP.<> PP.char ':') PP.<+>+ PP.fsep (map PP.text (words value))++showHeader :: CharSet -> Header -> PP.Doc+showHeader charset (field, value) =+ (PP.text (capital field) PP.<> PP.char ':') PP.<+>+ (PP.fsep $ map (PP.text . prepB64) $ separate value)+ where separate s | length s < 76 - length field = [s]+ | isJust (find isSpace s) =+ concatMap separate $ words s+ | length s < 998 - length field = [s]+ | otherwise =+ let (s', s'') = splitAt (998 - length field) s+ in s' : separate s''+ prepB64 s | isJust $ find (not.isPrint) s =+ "=?" ++ charset ++ "?b?" ++ b64Encode s ++ "?="+ | otherwise = s++capital :: String -> String+capital "" = ""+capital (c:cs) | isAlpha c = toUpper c : inner cs+ | otherwise = c : capital cs+ where inner "" = ""+ inner (c:cs) | isAlpha c = toLower c : inner cs+ | otherwise = c : capital cs++b64Encode :: String -> String+b64Encode = B64.encode . map (toEnum.ord)++showMessage :: CharSet -> Message -> PP.Doc+showMessage charset (hdrs, body) =+ PP.vcat ((map (showHeader charset) hdrs) +++ [ PP.empty, PP.text (BS.unpack body)])++showMime :: CharSet -> Mime -> PP.Doc+showMime charset (SinglePart hdrs body) =+ PP.vcat ((map (showHeader charset) hdrs) +++ [ PP.empty, PP.text (BS.unpack body)])+showMime charset (MultiPart hdrs bodies)+ | isJust $ lookup "Content-Type" hdrs =+ PP.vcat $ map (showHeader charset) hdrs +++ (PP.empty : mixture boundary (map (showMime charset) bodies))+ | otherwise =+ PP.vcat $ map (showHeader charset) (hdrs++[newHeader]) +++ (PP.empty : mixture newBoundary+ (map (showMime charset) bodies))+ where boundary = let s = fromJust $ lookup "Content-Type" hdrs+ s' = drop 9 $ head $+ dropWhile ((/="boundary=") . (take 9))+ (tails s)+ in if head s' == '"'+ then takeWhile (/='"') $ tail s'+ else takeWhile isAlphaNum s'+ newBoundary = md5Hash $ concatMap snd hdrs+ newHeader = ("Content-Type", "multipart/mixed; boundary=\"" ++ newBoundary ++ "\"")+ mixture b [] = [PP.text ("--"++b++"--")]+ mixture b (body:bodies) = PP.text ("--"++b) : body : mixture b bodies++md5Hash = showOctet . hash . map (toEnum.ord)+ where showOctet = concat . map hexChars+ hexChars c = [arr ! (c `div` 16), arr ! (c `mod` 16)]+ arr = listArray (0, 15) "0123456789abcdef"+
+ Text/Packrat/Parse.hs view
@@ -0,0 +1,351 @@+----------------------------------------------------------------------+-- |+-- Module : Text.Packrat.Parse+-- Copyright : (c) Bryan Ford+-- License : PublicDomain+-- +-- Maintainer : mukai@jmuk.org+-- Stability : stable+-- Portability : portable+-- +-- Packrat parsing: Simple, Powerful, Lazy, Linear time by Bryan Ford.+-- This module achieves monadic parsing library similar to Parsec.+-- ++++module Text.Packrat.Parse where++import Char+import List++import Text.Packrat.Pos++import Control.Monad++-- Data types++data Message = Expected String+ | Message String++data ParseError = ParseError { errorPos :: Pos+ , errorMessages :: [Message] }++data Result d v = Parsed v d ParseError+ | NoParse ParseError++newtype Parser d v = Parser (d -> Result d v)+++class Derivs d where+ dvPos :: d -> Pos+ dvChar :: d -> Result d Char+++-- Basic Combinators++infixl 2 <|>+infixl 1 <?>+infixl 1 <?!>++instance Derivs d => Monad (Parser d) where + (Parser p1) >>= f = Parser parse+ where parse dvs = first (p1 dvs)+ first (Parsed val rem err) = + let Parser p2 = f val+ in second err (p2 rem)+ first (NoParse err) = NoParse err+ second err1 (Parsed val rem err) =+ Parsed val rem (joinErrors err1 err)+ second err1 (NoParse err) =+ NoParse (joinErrors err1 err)+ return x = Parser (\dvs -> Parsed x dvs (nullError dvs))+ fail msg = Parser (\dvs -> NoParse (msgError (dvPos dvs) msg))++instance Derivs d => MonadPlus (Parser d) where+ mzero = Parser (\dvs -> NoParse $ nullError dvs)+ mplus = (<|>)++(<|>) :: Derivs d => Parser d v -> Parser d v -> Parser d v+(Parser p1) <|> (Parser p2) = Parser parse+ where parse dvs = first dvs (p1 dvs)+ first dvs (result @ (Parsed val rem err)) = result+ first dvs (NoParse err) = second err (p2 dvs)+ second err1 (Parsed val rem err) =+ Parsed val rem (joinErrors err1 err)+ second err1 (NoParse err) =+ NoParse (joinErrors err1 err)++satisfy :: Derivs d => Parser d v -> (v -> Bool) -> Parser d v+satisfy (Parser p) test = Parser parse+ where parse dvs = check dvs (p dvs)+ check dvs (result @ (Parsed val rem err)) =+ if test val+ then result+ else NoParse (nullError dvs)+ check dvs none = none++notFollowedBy :: (Derivs d, Show v) => Parser d v -> Parser d ()+notFollowedBy (Parser p) = Parser parse+ where parse dvs = case (p dvs) of+ Parsed val rem err ->+ NoParse (msgError (dvPos dvs)+ ("unexpected " ++ show val))+ NoParse err -> Parsed () dvs (nullError dvs)++optional :: Derivs d => Parser d v -> Parser d (Maybe v)+optional p = (do v <- p; return (Just v)) <|> return Nothing++option :: Derivs d => v -> Parser d v -> Parser d v+option v p = (do v' <- p; return v') <|> return v++many :: Derivs d => Parser d v -> Parser d [v]+many p = (do { v <- p; vs <- many p; return (v : vs) } )+ <|> return []++many1 :: Derivs d => Parser d v -> Parser d [v]+many1 p = do { v <- p; vs <- many p; return (v : vs) }++count :: Derivs d => Int -> Parser d v -> Parser d [v]+count n p = sequence $ replicate n p++sepBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v]+sepBy1 p psep = do v <- p+ vs <- many (do { psep; p })+ return (v : vs)++sepBy :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v]+sepBy p psep = sepBy1 p psep <|> return []++endBy :: Derivs d => Parser d v -> Parser d vend -> Parser d [v]+endBy p pend = many (do { v <- p; pend; return v })++endBy1 :: Derivs d => Parser d v -> Parser d vend -> Parser d [v]+endBy1 p pend = many1 (do { v <- p; pend; return v })++sepEndBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v]+sepEndBy1 p psep = do v <- sepBy1 p psep; optional psep; return v++sepEndBy :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v]+sepEndBy p psep = do v <- sepBy p psep; optional psep; return v++chainl1 :: Derivs d => Parser d v -> Parser d (v->v->v) -> Parser d v+chainl1 p psep = let psuffix z = (do f <- psep+ v <- p+ psuffix (f z v))+ <|> return z+ in do v <- p+ psuffix v++chainl :: Derivs d => Parser d v -> Parser d (v->v->v) -> v -> Parser d v+chainl p psep z = chainl1 p psep <|> return z++chainr1 :: Derivs d => Parser d v -> Parser d (v->v->v) -> Parser d v+chainr1 p psep = (do v <- p+ f <- psep+ w <- chainr1 p psep+ return (f v w))+ <|> p++chainr :: Derivs d => Parser d v -> Parser d (v->v->v) -> v -> Parser d v+chainr p psep z = chainr1 p psep <|> return z++choice :: Derivs d => [Parser d v] -> Parser d v+choice [p] = p+choice (p:ps) = p <|> choice ps+++manyTill :: Derivs d => Parser d v -> Parser d vend -> Parser d [v]+manyTill p pend = (pend >> return [])+ <|> do tok <- p+ rest <- manyTill p pend+ return (tok:rest)++between :: Derivs d => Parser d vs -> Parser d ve -> Parser d v -> Parser d v+between s e main = do s+ v <- main+ e+ return v++-- Error handling+instance Eq Message where+ Expected e1 == Expected e2 = e1 == e2+ Message m1 == Message m2 = m1 == m2+ _ == _ = False++failAt :: Derivs d => Pos -> String -> Parser d v+failAt pos msg = Parser (\dvs -> NoParse (msgError pos msg))++-- Annotate a parser with a description of the construct to be parsed.+-- The resulting parser yields an "expected" error message+-- if the construct cannot be parsed+-- and if no error information is already available+-- indicating a position farther right in the source code+-- (which would normally be more localized/detailed information).+(<?>) :: Derivs d => Parser d v -> String -> Parser d v+(Parser p) <?> desc = Parser (\dvs -> munge dvs (p dvs))+ where munge dvs (Parsed v rem err) =+ Parsed v rem (fix dvs err)+ munge dvs (NoParse err) =+ NoParse (fix dvs err)+ fix dvs (err @ (ParseError p ms)) =+ if p > dvPos dvs+ then err+ else expError (dvPos dvs) desc++-- Stronger version of the <?> error annotation operator above,+-- which unconditionally overrides any existing error information.+(<?!>) :: Derivs d => Parser d v -> String -> Parser d v+(Parser p) <?!> desc = Parser (\dvs -> munge dvs (p dvs))+ where munge dvs (Parsed v rem err) =+ Parsed v rem (fix dvs err)+ munge dvs (NoParse err) =+ NoParse (fix dvs err)+ fix dvs (err @ (ParseError p ms)) =+ expError (dvPos dvs) desc++-- Potentially join two sets of ParseErrors,+-- but only if the position didn't change from the first to the second.+-- If it did, just return the "new" (second) set of errors.+joinErrors (e @ (ParseError p m)) (e' @ (ParseError p' m'))+ | p' > p || null m = e'+ | p > p' || null m' = e+ | otherwise = ParseError p (m `union` m')++nullError dvs = ParseError (dvPos dvs) []++expError pos desc = ParseError pos [Expected desc]++msgError pos msg = ParseError pos [Message msg]++eofError dvs = msgError (dvPos dvs) "end of input"++expected :: Derivs d => String -> Parser d v+expected desc = Parser (\dvs -> NoParse (expError (dvPos dvs) desc))++unexpected :: Derivs d => String -> Parser d v+unexpected str = fail ("unexpected " ++ str)+++-- Comparison operators for ParseError just compare relative positions.+instance Eq ParseError where+ ParseError p1 m1 == ParseError p2 m2 = p1 == p2+ ParseError p1 m1 /= ParseError p2 m2 = p1 /= p2++instance Ord ParseError where+ ParseError p1 m1 < ParseError p2 m2 = p1 < p2+ ParseError p1 m1 > ParseError p2 m2 = p1 > p2+ ParseError p1 m1 <= ParseError p2 m2 = p1 <= p2+ ParseError p1 m1 >= ParseError p2 m2 = p1 >= p2+ -- Special behavior: "max" joins two errors+ max p1 p2 = joinErrors p1 p2+ min p1 p2 = undefined++instance Show ParseError where+ show (ParseError pos []) = + show pos ++ ": unknown error"+ show (ParseError pos msgs) = expectmsg expects ++ messages msgs+ where expects = getExpects msgs+ getExpects [] = []+ getExpects (Expected exp : rest) = exp : getExpects rest+ getExpects (Message msg : rest) = getExpects rest+ expectmsg [] = ""+ expectmsg [exp] = show pos ++ ": expecting " ++ exp ++ "\n"+ expectmsg [e1, e2] = show pos ++ ": expecting either "+ ++ e1 ++ " or " ++ e2 ++ "\n"+ expectmsg (first : rest) = show pos ++ ": expecting one of: "+ ++ first ++ expectlist rest ++ "\n"+ expectlist [last] = ", or " ++ last+ expectlist (mid : rest) = ", " ++ mid ++ expectlist rest+ messages [] = []+ messages (Expected exp : rest) = messages rest+ messages (Message msg : rest) =+ show pos ++ ": " ++ msg ++ "\n" ++ messages rest+++-- Character-oriented parsers++anyChar :: Derivs d => Parser d Char+anyChar = Parser dvChar++char :: Derivs d => Char -> Parser d Char+char ch = satisfy anyChar (\c -> c == ch) <?> show ch++oneOf :: Derivs d => [Char] -> Parser d Char+oneOf chs = satisfy anyChar (\c -> c `elem` chs)+ <?> ("one of the characters " ++ show chs)++noneOf :: Derivs d => [Char] -> Parser d Char+noneOf chs = satisfy anyChar (\c -> not (c `elem` chs))+ <?> ("any character not in " ++ show chs)+++charIf :: Derivs d => (Char -> Bool) -> Parser d Char+charIf p = satisfy anyChar p <?> "predicate is not satisfied"++string :: Derivs d => String -> Parser d String+string str = p str <?> show str+ where p [] = return str+ p (ch:chs) = do { char ch; p chs }++stringFrom :: Derivs d => [String] -> Parser d String+stringFrom [str] = string str+stringFrom (str : strs) = string str <|> stringFrom strs++upper :: Derivs d => Parser d Char+upper = satisfy anyChar isUpper <?> "uppercase letter"++lower :: Derivs d => Parser d Char+lower = satisfy anyChar isLower <?> "lowercase letter"++letter :: Derivs d => Parser d Char+letter = satisfy anyChar isAlpha <?> "letter"++alphaNum :: Derivs d => Parser d Char+alphaNum = satisfy anyChar isAlphaNum <?> "letter or digit"++digit :: Derivs d => Parser d Char+digit = satisfy anyChar isDigit <?> "digit"++hexDigit :: Derivs d => Parser d Char+hexDigit = satisfy anyChar isHexDigit <?> "hexadecimal digit (0-9, a-f)"++octDigit :: Derivs d => Parser d Char+octDigit = satisfy anyChar isOctDigit <?> "octal digit (0-7)"++newline :: Derivs d => Parser d Char+newline = char '\n'++tab :: Derivs d => Parser d Char+tab = char '\t'++space :: Derivs d => Parser d Char+space = satisfy anyChar isSpace <?> "whitespace character"++spaces :: Derivs d => Parser d [Char]+spaces = many space++eof :: Derivs d => Parser d ()+eof = notFollowedBy anyChar <?> "end of input"+++-- State manipulation++getDerivs :: Derivs d => Parser d d+getDerivs = Parser (\dvs -> Parsed dvs dvs (nullError dvs))++setDerivs :: Derivs d => d -> Parser d ()+setDerivs newdvs = Parser (\dvs -> Parsed () newdvs (nullError dvs))++getPos :: Derivs d => Parser d Pos+getPos = Parser (\dvs -> Parsed (dvPos dvs) dvs (nullError dvs))+++-- Special function that converts a Derivs "back" into an ordinary String+-- by extracting the successive dvChar elements.+dvString :: Derivs d => d -> String+dvString d =+ case dvChar d of+ NoParse err -> []+ Parsed c rem err -> (c : dvString rem)+
+ Text/Packrat/Pos.hs view
@@ -0,0 +1,33 @@+-- Simple data type to keep track of character positions+-- within a text file or other text stream.+module Text.Packrat.Pos where+++data Pos = Pos { posFile :: !String+ , posLine :: !Int+ , posCol :: !Int+ }++nextPos (Pos file line col) c+ | c == '\n' = Pos file (line + 1) 1+ | c == '\t' = Pos file line ((div (col + 8 - 1) 8) * 8 + 1)+ | otherwise = Pos file line (col + 1)++instance Eq Pos where+ Pos f1 l1 c1 == Pos f2 l2 c2 =+ f1 == f2 && l1 == l2 && c1 == c2++instance Ord Pos where+ Pos f1 l1 c1 <= Pos f2 l2 c2 =+ (l1 < l2) || (l1 == l2 && c1 <= c2)++instance Show Pos where+ show (Pos file line col) = file ++ ":" ++ show line ++ ":" ++ show col+++showPosRel (Pos file line col) (Pos file' line' col')+ | file == file' =+ if (line == line')+ then "column " ++ show col'+ else "line " ++ show line' ++ ", column " ++ show col'+ | otherwise = show (Pos file' line' col')
+ Text/RSS.hs view
@@ -0,0 +1,239 @@+{-# OPTIONS -fglasgow-exts #-}+----------------------------------------------------------------------+-- |+-- Module : Text.RSS+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : experimental+-- Portability : portable+-- +-- RSS 1.0 Printer Library (printing such like Text.HTML)+-- ++module Text.RSS+ ( RSSItem(..), RSSChannel(..), RSSImage(..), DublinCore(..)+ , ATitle(..), ALink(..), ADescription(..), AContent(..), ADC(..)+ , AImage(..), AItems(..), AUri(..)+ , RSSITEM(..), RSSCHANNEL(..), RSSIMAGE(..)+ , rss2Elem, rss2ElemWithAttrs, defaultAttrs, elem2rss+ , Attr, get, set, update, has, add, howMany, set', get', delete+ )+where++import Data.Char (ord)+import Data.Record+import Data.List (isPrefixOf)+import Data.Maybe+import Data.Time.Calendar (fromGregorian)+import Data.Time (formatTime)+import Data.Time.LocalTime+import System.Locale (defaultTimeLocale)+import Text.XML.HaXml+import Text.XML.HaXml.Xml2Haskell++data RSSItem = RSSItem { itemTitle :: String + , itemLink :: String+ , itemDescription :: Maybe String+ , itemContent :: Maybe String+ , itemDC :: [DublinCore]+ }++data RSSChannel = RSSChannel { chTitle :: String+ , chURI :: String+ , chLink :: String+ , chDescription :: String+ , chDC :: [DublinCore]+ , chImage :: Maybe RSSImage+ , chItems :: [RSSItem]+ }+data RSSImage = RSSImage { imURI :: String+ , imTitle :: String+ , imLink :: String+ } ++data DublinCore = DCCreator String + | DCDate ZonedTime+ | DCSubject String++class ATitle r v | r -> v where title :: Attr r v+class ALink r v | r -> v where link :: Attr r v+class ADescription r v | r -> v where description :: Attr r v+class AContent r v | r -> v where content :: Attr r v+class ADC r v | r -> v where dc :: Attr r v+class AImage r v | r -> v where image :: Attr r v+class AItems r v | r -> v where items :: Attr r v+class AUri r v | r -> v where uri :: Attr r v++class ( ATitle r String, ALink r String, ADescription r (Maybe String)+ , AContent r (Maybe String), ADC r [DublinCore]) + => RSSITEM r+class ( ATitle r String, AUri r String, ALink r String, ADescription r String+ , ADC r [DublinCore], AImage r (Maybe RSSImage), AItems r [RSSItem])+ => RSSCHANNEL r+class (AUri r String, ATitle r String, ALink r String) => RSSIMAGE r++instance ATitle RSSItem String where+ title = Attr itemTitle setter+ where setter r v = r { itemTitle = v }+instance ALink RSSItem String where+ link = Attr itemLink setter+ where setter r v = r { itemLink = v }+instance ADescription RSSItem (Maybe String) where+ description = Attr itemDescription setter+ where setter r v = r { itemDescription = v }+instance AContent RSSItem (Maybe String) where+ content = Attr itemContent setter+ where setter r v = r { itemContent = v }+instance ADC RSSItem [DublinCore] where+ dc = Attr itemDC setter+ where setter r v = r { itemDC = v }+instance RSSITEM RSSItem++instance ATitle RSSChannel String where+ title = Attr chTitle setter+ where setter r v = r { chTitle = v }+instance AUri RSSChannel String where+ uri = Attr chTitle setter+ where setter r v = r { chURI = v }+instance ALink RSSChannel String where+ link = Attr chLink setter+ where setter r v = r { chLink = v }+instance ADescription RSSChannel String where+ description = Attr chDescription setter+ where setter r v = r { chDescription = v }+instance ADC RSSChannel [DublinCore] where+ dc = Attr chDC setter+ where setter r v = r { chDC = v }+instance AImage RSSChannel (Maybe RSSImage) where+ image = Attr chImage setter+ where setter r v = r { chImage = v }+instance AItems RSSChannel [RSSItem] where+ items = Attr chItems setter+ where setter r v = r { chItems = v }+instance RSSCHANNEL RSSChannel++instance AUri RSSImage String where+ uri = Attr imURI setter+ where setter r v = r { imURI = v }+instance ATitle RSSImage String where+ title = Attr imTitle setter+ where setter r v = r { imTitle = v }+instance ALink RSSImage String where+ link = Attr imLink setter+ where setter r v = r { imLink = v }++fromText' :: String -> [Content] -> [String]+fromText' t = map (concat . fst . many fromText) . dropWhile null . map (tag t /> keep)+toText' :: String -> String -> Content+toText' tag cont = CElem $ Elem tag [] [CString False cont]+toText'' tag cont = CElem $ Elem tag [] [CString True cont]++instance XmlContent RSSImage where+ fromElem (CElem (Elem "image" ats cs) : rest) =+ (Just $ RSSImage u' t l, rest)+ where t = concat $ fromText' "title" cs+ l = concat $ fromText' "link" cs+ u' = concat $ fromText' "url" cs+ fromElem rest = (Nothing, rest)+ toElem (RSSImage u t l) = [CElem $ escape $ Elem "image" [about] $ zipWith toText' ["title", "link", "url"] [u, t, l]]+ where about = ("rdf:resource", str2attr u)++instance XmlContent DublinCore where+ fromElem (CElem (Elem "dc:creator" _ cs) : rest) =+ (Just $ DCCreator (concat $ fst $ many fromText cs), rest)+ fromElem (CElem (Elem "dc:subject" _ cs) : rest) =+ (Just $ DCSubject (concat $ fst $ many fromText cs), rest)+ fromElem (CElem (Elem "dc:date" _ cs) : rest) =+ (Just $ DCDate $ ZonedTime (LocalTime (fromGregorian (read year) (read mon) (read day)) (TimeOfDay (read hour) (read min) (fromRational $ toRational (read sec::Double)))) zone, rest)+ where s = concat $ fst $ many fromText cs+ (d, _:h') = break (=='T') s+ (h, z) = break (`elem` "+-Z") h'+ (year:mon:day:_) = breaks '-' d+ (hour:min:sec:_) = breaks ':' h+ zone = case z of+ "Z" -> utc+ zs@(_:_) -> + let (zh:zm:_) = map read $ breaks ':' zs+ in minutesToTimeZone ((abs zh * 60 + zm) * signum zh)+ _ -> utc+ breaks c d = case break (==c) d of+ (s, "") -> [s]+ (s, rest) -> s : breaks c rest+ fromElem rest = (Nothing, rest)+ toElem (DCCreator c) = [toText' "dc:creator" c]+ toElem (DCSubject s) = [toText' "dc:subject" s]+ toElem (DCDate (ZonedTime d (TimeZone diffs _ _))) = [toText' "dc:date" dateStr]+ where dateStr = formatTime defaultTimeLocale "%FT%T" d ++ zs+ zs = if diffs == 0 then "Z"+ else let (zh,zm) = diffs `divMod` 60+ (zh',zm') = if diffs < 0 && zm /= 0 + then (zh+1,60-zm) else (zh,zm)+ sig = if zh' < 0 then '-' else '+'+ in sig : show2 zh' ++ ":" ++ show2 zm'+ show2 n | abs n < 10 = '0':show (abs n)+ | otherwise = show n++instance XmlContent RSSItem where+ fromElem (CElem (Elem "item" ats cs) : rest) =+ (Just $ RSSItem t l d c dcs, rest)+ where t = concat $ fromText' "title" cs+ l = concat $ fromText' "link" cs+ d = listToMaybe $ fromText' "description" cs+ c = listToMaybe $ fromText' "content:encoded" cs+ dcs = fst $ many fromElem $ concatMap (tagWith (isPrefixOf "dc:")) cs+ fromElem rest = (Nothing, rest)+ toElem (RSSItem t l d c dcs) = [CElem $ escape $ Elem "item" [("rdf:about", str2attr l)] ([tt, lt] ++ catMaybes [dt, ct] ++ dct)]+ where tt = toText' "title" t+ lt = toText' "link" l+ dt = d >>= return . toText' "description"+ ct = c >>= return . toText'' "content:encoded"+ dct = concatMap toElem dcs++instance XmlContent RSSChannel where+ fromElem (CElem (Elem "channel" ats cs) : rest) =+ (Just $ RSSChannel t u l d dcs Nothing [], rest)+ where t = concat $ fromText' "title" cs+ u = definiteA fromAttrToStr "about" "" ats+ l = concat $ fromText' "link" cs+ d = concat $ fromText' "description" cs+ dcs = fst $ many fromElem $ concatMap (tagWith (isPrefixOf "dc:")) cs+ fromElem rest = (Nothing, rest)+ toElem (RSSChannel t u l d dcs im is) = [CElem $ escape $ Elem "channel" [("rdf:about", str2attr u)] ([tt, lt, dt, ist]++imt++dct)]+ where tt = toText' "title" t+ lt = toText' "link" l+ dt = toText' "description" d+ imt = map (\im' -> CElem $ Elem "image" [("rdf:resource", str2attr $ get link im')] []) $ maybeToList im+ ist = CElem $ Elem "items" [] + [CElem $ Elem "rdf:Seq" [] (map (l2li . get link) is)]+ dct = concatMap toElem dcs+ l2li l = CElem $ escape $ Elem "rdf:li" [("rdf:resource", str2attr l)] []+++rss2Elem :: RSSChannel -> Element+rss2Elem = rss2ElemWithAttrs defaultAttrs+rss2ElemWithAttrs :: [(String, String)] -> RSSChannel -> Element+rss2ElemWithAttrs attrs ch = + escape $ Elem "rdf:RDF" attrs' (toElem ch++toElem img++concatMap toElem es++toElem img)+ where img = get image ch+ es = get items ch+ attrs' = map (\(f, v) -> (f, str2attr v)) attrs++elem2rss :: Element -> RSSChannel+elem2rss (Elem "rdf:RDF" _ cs) = ch { chItems = is, chImage = img }+ where (Just ch, cs') = fromElem cs+ is = fst $ many fromElem $ concatMap (tag "item") cs'+ img = fst $ fromElem $ concatMap (tag "image") cs'++defaultAttrs = [ ("xmlns", "http://purl.org/rss/1.0/")+ , ("xmlns:rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ , ("xmlns:dc", "http://purl.org/dc/elements/1.1/")+ , ("xmlns:content", "http://purl.org/rss/1.0/modules/content/")+ ] ++escape = xmlEscape rssXmlEscaper++rssXmlEscaper = mkXmlEscaper [('<', "lt"),('>',"gt"),('&',"amp"),('\'',"apos"),('"',"quot")] f+ where f ch = i < 32 || i > 255 || (ch `elem` "\"&<>")+ where i = ord ch
+ Text/URI.hsc view
@@ -0,0 +1,230 @@+{-# OPTIONS -fglasgow-exts #-}+----------------------------------------------------------------------+-- |+-- Module : Text.URI+-- Copyright : (c) Jun Mukai 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : mukai@jmuk.org+-- Stability : stable+-- Portability : portable+-- +-- URI parser and utilities+-- +++module Text.URI+ ( URI(..)+ , port'+ , uri, uri'+ , escape, unescape+ , parseURI, parseURI'+ , portToName, nameToPort+ )+ where++import Network+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS++import Text.Packrat.Parse+import Text.Packrat.Pos++import Data.Array+import Data.Char+import Data.List+import Data.Maybe+import Data.Word (Word8)+import Numeric++import Network.BSD (getServicePortNumber, getServiceByPort, serviceName, servicePort)+import System.IO.Unsafe++data URI = URI { scheme :: String+ , host :: String+ , user :: String+ , password :: String+ , port :: Maybe PortNumber+ , path :: String+ , query :: String+ , fragment :: String+ }+#ifdef DEBUG+ deriving (Eq, Show)+#else+ deriving (Eq)++instance Show URI where+ showsPrec d uri = showParen (d>app_prec) $ foldl1 (.) $ show' uri+ where app_prec = 10+ show' (URI sch host u p port path q f) =+ [ showScheme sch+ , showUserInfo (escape $ map c2w u) (escape $ map c2w p)+ , showString $ escape $ map c2w host+ , showPort port+ , showString $ escape $ map c2w path+ , showQuery $ escape $ map c2w q+ , showFragment $ escape $ map c2w f ]+ showScheme "" = id+ showScheme s = showString s . ("://"++)+ showUserInfo "" "" = id+ showUserInfo u "" = showString u . ('@':)+ showUserInfo u p = showString u . (':':)+ . showString p . ('@':)+ showPort Nothing = id+ showPort (Just p) = (':':) . showInt p+ showQuery "" = id+ showQuery q = ('?':) . showString q+ showFragment "" = id+ showFragment f = ('#':) . showFragment f+ c2w = toEnum . fromEnum+#endif++-- | Obtain the port number for the URI. If no port number exists,+-- port' would like to estimate the port number from the scheme name.+-- If both failed, it raises an error.+port' :: URI -> PortNumber+port' (URI { port = Just p }) = p+port' (URI { scheme = s }) =+ case nameToPort s of+ Just p -> p+ Nothing -> error ("no service entries for " ++ s)++ +-- | Parse URI string simiar to 'parseURI'. The difference is that it+-- raises an error for the case of parse failed, not returns Nothing.+uri' :: ByteString -> URI+uri' u = case dvURI (parse (Pos "<uri>" 1 1) u) of+ Parsed v d' e' -> v+ NoParse e -> error (show e)+uri :: String -> URI+uri = uri' . BS.pack++-- | Parse URI string and returns the result. If the parse is failed,+-- it simply returns Nothing.+parseURI :: String -> Maybe URI+parseURI = parseURI' . BS.pack+parseURI' :: ByteString -> Maybe URI+parseURI' u = case dvURI (parse (Pos "<uri>" 1 1) u) of+ Parsed v d' e' -> Just v+ NoParse e -> Nothing ++parse pos s = d+ where d = URIDerivs puri psch phost pui pport pabs ppath pq pf pch pos+ puri = pURI d+ psch = pScheme d+ phost = pHost d+ pui = pUserInfo d+ pport = pPort d+ pabs = pPathAbs d+ ppath = pPath d+ pq = pQuery d+ pf = pFragment d+ pch | BS.null s = NoParse (eofError d)+ | otherwise =+ let (c, s') = (BS.head s, BS.tail s)+ in Parsed c (parse (nextPos pos c) s') (nullError d)++ ++data URIDerivs = URIDerivs { dvURI :: Result URIDerivs URI+ , dvScheme :: Result URIDerivs String+ , dvHost :: Result URIDerivs String+ , dvUserInfo :: Result URIDerivs [String]+ , dvPort :: Result URIDerivs PortNumber+ , dvPathAbs :: Result URIDerivs String+ , dvPath :: Result URIDerivs String+ , dvQuery :: Result URIDerivs String+ , dvFragment :: Result URIDerivs String+ , advChar :: Result URIDerivs Char+ , advPos :: Pos+ }++instance Derivs URIDerivs where+ dvChar = advChar+ dvPos = advPos+++unescape :: String -> String+unescape ('%':c1:c2:cs) = chr ((hex c1)*16+(hex c2)) : unescape cs+ where arr = array ('0', 'f') $ zip "0123456789abcdef" [0..]+ hex = (arr!) . toLower+unescape (c:cs) = c : unescape cs+unescape "" = ""++escape :: [Word8] -> String+escape [] = ""+escape (c:cs) | c' `elem` validChars = c' : escape cs+ | otherwise = escChar c ++ escape cs+ where validChars = ['a'..'z']++['A'..'Z']++['0'..'9']++"!$^&*-_=+|/."+ escChar c = '%' : map (arr!) [c `div` 16, c `mod` 16]+ arr = listArray (0, 15) "0123456789abcdef"+ w2c = toEnum . fromEnum+ c' = w2c c++consURI :: String -- ^ scheme+ -> String -- ^ host name+ -> String -- ^ user+ -> String -- ^ password+ -> Maybe PortNumber+ -> String -- ^ path+ -> String -- ^ query+ -> String -- ^ fragment+ -> URI+consURI s h u p port path q f =+ URI (unescape s) (unescape h) (unescape u) (unescape p) port (unescape path) (unescape q) (unescape f)+++pURI :: URIDerivs -> Result URIDerivs URI+Parser pURI = do sch <- Parser dvScheme+ char ':'+ uri <- hierPart sch+ q <- option "" (Parser dvQuery)+ f <- option "" (Parser dvFragment)+ eof+ return (uri { query = q, fragment = f })+ where hierPart sch = do string "//"+ ui <- option [] (Parser dvUserInfo)+ host <- Parser dvHost+ port <- optional (Parser dvPort)+ path <- option "" (Parser dvPathAbs)+ let uri = consURI sch host "" "" port path "" ""+ case ui of+ [u, p] -> return $ uri { user = u, password = p }+ [u] -> return $ uri { user = u }+ [] -> return uri+ <|> do path <- option "" (Parser dvPath)+ return $ URI sch "" "" "" Nothing path "" ""++pScheme, pHost, pPath, pQuery, pFragment :: URIDerivs+ -> Result URIDerivs String+Parser pScheme = do c <- oneOf (['a'..'z']++['A'..'Z'])+ rest <- many $ oneOf (['a'..'z']++['A'..'Z']++['0'..'9']++"+-.")+ return (c:rest)+Parser pHost = many1 (noneOf ":/")+Parser pPathAbs = char '/' >> Parser dvPath >>= return . ('/':)+Parser pPath = many1 (noneOf "#?")+Parser pQuery = char '?' >> many1 (noneOf "#")+Parser pFragment = char '#' >> many1 anyChar+++pUserInfo :: URIDerivs -> Result URIDerivs [String]+Parser pUserInfo = do ui <- many1 (noneOf ":@") `sepBy1` char ':'+ char '@'+ return ui++pPort :: URIDerivs -> Result URIDerivs PortNumber+Parser pPort = char ':' >> many1 digit >>= return . toEnum . read+++portToName :: PortNumber -> Maybe String+portToName p = unsafePerformIO $+ (do s <- getServiceByPort p "tcp"+ return $ Just $ serviceName s)+ `catch`+ (\_ -> return Nothing)++nameToPort :: String -> Maybe PortNumber+nameToPort n = unsafePerformIO $+ fmap Just (getServicePortNumber n)+ `catch` (\_ -> return Nothing)