diff --git a/Data/Record.hs b/Data/Record.hs new file mode 100644 --- /dev/null +++ b/Data/Record.hs @@ -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 + diff --git a/HaskellNet.cabal b/HaskellNet.cabal new file mode 100644 --- /dev/null +++ b/HaskellNet.cabal @@ -0,0 +1,28 @@ +Name: HaskellNet +Version: 0.2.1 +Author: Jun Mukai +Maintainer: Robert Wills +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 diff --git a/HaskellNet/Auth.hs b/HaskellNet/Auth.hs new file mode 100644 --- /dev/null +++ b/HaskellNet/Auth.hs @@ -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 diff --git a/HaskellNet/BSStream.hs b/HaskellNet/BSStream.hs new file mode 100644 --- /dev/null +++ b/HaskellNet/BSStream.hs @@ -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 diff --git a/HaskellNet/IMAP.hs b/HaskellNet/IMAP.hs new file mode 100644 --- /dev/null +++ b/HaskellNet/IMAP.hs @@ -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 diff --git a/HaskellNet/POP3.hs b/HaskellNet/POP3.hs new file mode 100644 --- /dev/null +++ b/HaskellNet/POP3.hs @@ -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 diff --git a/HaskellNet/SMTP.hs b/HaskellNet/SMTP.hs new file mode 100644 --- /dev/null +++ b/HaskellNet/SMTP.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain +--main = defaultMainWithHooks defaultUserHooks diff --git a/Text/Atom.hs b/Text/Atom.hs new file mode 100644 --- /dev/null +++ b/Text/Atom.hs @@ -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 diff --git a/Text/Bencode.hs b/Text/Bencode.hs new file mode 100644 --- /dev/null +++ b/Text/Bencode.hs @@ -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' diff --git a/Text/IMAPParsers.hs b/Text/IMAPParsers.hs new file mode 100644 --- /dev/null +++ b/Text/IMAPParsers.hs @@ -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" diff --git a/Text/Mime.hs b/Text/Mime.hs new file mode 100644 --- /dev/null +++ b/Text/Mime.hs @@ -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 "" 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 "" 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 "" 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" + diff --git a/Text/Packrat/Parse.hs b/Text/Packrat/Parse.hs new file mode 100644 --- /dev/null +++ b/Text/Packrat/Parse.hs @@ -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) + diff --git a/Text/Packrat/Pos.hs b/Text/Packrat/Pos.hs new file mode 100644 --- /dev/null +++ b/Text/Packrat/Pos.hs @@ -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') diff --git a/Text/RSS.hs b/Text/RSS.hs new file mode 100644 --- /dev/null +++ b/Text/RSS.hs @@ -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 diff --git a/Text/URI.hsc b/Text/URI.hsc new file mode 100644 --- /dev/null +++ b/Text/URI.hsc @@ -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 "" 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 "" 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)