{- | Module : $Header$ Description : RFC977 implementation (which is the most popular version). Copyright : (c) Maciej Piechotka License : LGPL 3 or later Maintainer : uzytkownik2@gmail.com Stability : none Portability : portable RFC977 is the most popular version of protocol. -} module Network.NNTP.RFC977 ( -- * Types Connection, -- * Functions joinToSocket, joinToHandle, connectToHost, ) where import Control.Arrow import Control.Exception(Exception,throw) import Control.Monad import Data.ByteString.Char8 as B import Data.Maybe import Data.Time import Data.Word import Locale import Network.Socket import Network.NNTP hiding (Connection) import qualified Network.NNTP(Connection) import Prelude as P import System.IO hiding (hGetLine,hPutStr) {- | An RFC977 connection. -} data Connection = Connection { handle :: System.IO.Handle } -- | Usage existing Socket and creating from it connection. joinToSocket :: Socket -- ^ The existing socket -> IO (Connection, Bool) -- ^ Returns connection and a bool -- indicating if posting is allowed joinToSocket = flip socketToHandle ReadWriteMode >=> joinToHandle -- | Usage existing Handle and creating from it connection. joinToHandle :: System.IO.Handle -- ^ Existing handle -> IO (Connection, Bool) -- ^ Returns connection and a bool -- indicating if posting is allowed joinToHandle h = do let c = Connection h hSetBuffering h LineBuffering l <- cGetLine c case (B.unpack $ B.take 3 l) of "200" -> return (c, True) "201" -> return (c, False) _ -> error "Unknown response" -- | Connects to NNTP server connectToHost :: String -- ^ A server name -> Maybe Word16 -- ^ Server port. Nothing indicates default -> IO (Connection, Bool) -- ^ Returns connection and a bool -- indicating if posting is allowed connectToHost = curry $ runKleisli c2H where c2H = second (arr (fromMaybe "nntp" . fmap show)) >>> arr (Just *** Just) >>> Kleisli (uncurry (getAddrInfo Nothing)) >>> arr P.head >>> (Kleisli ai2socket) &&& (arr addrAddress) >>> Kleisli (\(s, a) -> connect s a >> return s) >>> Kleisli joinToSocket ai2socket ai = socket (addrFamily ai) Stream 0 instance Network.NNTP.Connection Connection where articleFromID c i = stat c i articleFromNo c g i = fetchGroup c g >> stat c (show i) groupFromName c n = _group c n forGroups = list forNewGroups = newgroups forArticles c g f = fetchGroup c g >> stat c "" >>= process where getNext = next c >>= process process Nothing = return [] process (Just a) = do v <- f a r <- getNext return $ v:r forNewArticles = newnews fetchArticle c a = article c (articleID a) >>= justOrThrowM NoSuchArticle fetchArticleHeader c a = na `fmap` (justOrThrowM NoSuchArticle =<< h) where i = articleID a b = articleBody a na a' = Article i (articleHeader a') b h = Network.NNTP.RFC977.head c i fetchArticleBody c a = na `fmap` (justOrThrowM NoSuchArticle =<< body c i) where i = articleID a h = articleHeader a na a' = Article i h (articleBody a') fetchGroup c g = justOrThrowM NoSuchGroup =<< _group c (groupName g) post = Network.NNTP.RFC977.post disconnect = quit article :: Connection -> String -> IO (Maybe Article) article c i = cSendCommand c ("ARTICLE" ++ i) $ articleCommandH 220 c head :: Connection -> String -> IO (Maybe Article) head c i = cSendCommand c ("HEAD " ++ i) $ articleCommandH 221 c body :: Connection -> String -> IO (Maybe Article) body c i = cSendCommand c ("BODY " ++ i) $ articleCommandH 222 c stat :: Connection -> String -> IO (Maybe Article) stat c i = cSendCommand c ("STAT " ++ i) $ articleCommandH 223 c _group :: Connection -> String -> IO (Maybe Group) _group c n = cSendCommand c ("GROUP " ++ n) groupCommandH' where groupCommandH' 211 s = return $ Just $ createGroup s groupCommandH' 411 _ = return Nothing groupCommandH' _ _ = error "Unknown response" createGroup s = Group (w!!3) (read (w!!1)) (read (w!!2)) where w = P.words $ unpack s --last :: Connection -> IO (Maybe Article) --last c = cSendCommand c "LAST" $ articleCommandH 223 c list :: Connection -> (Group -> IO a) -> IO [a] list c f = cSendCommand c "LIST" $ groupCommandH c f newgroups :: Connection -> UTCTime -> (Group -> IO a) -> IO [a] newgroups c t f = cSendCommand c ("NEWGROUPS " ++ (pTime t) ++ " GMT") $ ngH where ngH = groupCommandH c f newnews :: Connection -> Group -> UTCTime -> (Article -> IO a) -> IO [a] newnews c g t f = cSendCommand c ("NEWNEWS " ++ s ++ " GMT") nnH where nnH 239 _ = cGetText c (f . createArticle) nnH 400 _ = throw ServiceDiscontinued nnH _ _ = error "Unknown response" s :: String s = (groupName g) ++ (pTime t) createArticle :: ByteString -> Article createArticle st = Article (unpack st) Nothing Nothing next :: Connection -> IO (Maybe Article) next c = cSendCommand c "NEXT" $ articleCommandH 223 c post :: Connection -> ByteString -> IO () post c p = cSendCommand c "POST" postH where postH 340 _ = cPutText c p >> cGetLine c >>= check where check = checkS . P.take 3 . unpack checkS "240" = return () checkS "400" = throw ServiceDiscontinued checkS "441" = throw PostingFailed checkS _ = error "Unknown response" postH 400 _ = throw ServiceDiscontinued postH 440 _ = throw PostingNotAllowed postH _ _ = error "Unknown response" quit :: Connection -> IO () quit c = cSendCommand c "QUIT" quitH where quitH 205 _ = return () quitH 400 _ = throw ServiceDiscontinued quitH _ _ = error "Unknown response" pTime :: UTCTime -> String pTime = formatTime defaultTimeLocale "%y%m%d %H%M%S" articleCommandH :: Int -> Connection -> Int -> ByteString -> IO (Maybe Article) articleCommandH e c r i | e == r = case r of 220 -> p2A `fmap` getContentA 221 -> h2A `fmap` getContent 222 -> b2A `fmap` getContent 223 -> return $ Just $ Article aID Nothing Nothing _ -> error "Internal error: unknown expected response" | r == 412 = error "Internal error: no group selected" | r == 420 = error "Internal error: no article selected" | r == 421 = return Nothing | r == 422 = return Nothing | r == 423 = return Nothing | r == 430 = return Nothing | r == 440 = throw ServiceDiscontinued | otherwise = error "Unknown response" where aID = (P.words $ B.unpack i)!!1 p2A = Just <<< uncurry (Article aID) <<< (justJoin *** justJoin) h2A = Just . flip (Article aID) Nothing . Just b2A = Just . Article aID Nothing . Just getContent = B.concat `fmap` cGetText c return getContentA = P.span (==empty) `fmap` cGetText c return justJoin = Just . intercalate nEOFSeq groupCommandH :: Connection -> (Group -> IO a) -> Int -> ByteString -> IO [a] groupCommandH c f 215 _ = cGetText c (f . createGroup) where createGroup s = Group (w!!0) (read (w!!2)) (read (w!!3)) where w = P.words $ unpack s groupCommandH _ _ 400 _ = throw ServiceDiscontinued groupCommandH _ _ _ _ = error "Unknown response" cSendCommand :: Connection -> String -> (Int -> ByteString -> IO a) -> IO a cSendCommand c k f = cPutLine c (pack k) >> cGetLine c >>= (id &&& id >>> read . unpack . B.take 3 *** B.drop 4 >>> uncurry f) justOrThrowM :: (Monad m, Exception b) => b -> Maybe a -> m a justOrThrowM _ (Just x) = return x justOrThrowM e Nothing = throw e hEOLSeq :: ByteString hEOLSeq = singleton '\n' nEOLSeq :: ByteString nEOLSeq = pack "\r\n" nEOFSeq :: ByteString nEOFSeq = pack "\r\n.\r\n" cPutLine :: Connection -> ByteString -> IO () cPutLine c s = hPutStr (handle c) s >> hPutStr (handle c) nEOLSeq >> hFlush (handle c) cPutText :: Connection -> ByteString -> IO () cPutText c s = mapM_ (cPutLine c) (P.map postize (lines' s)) >> hPutStr (handle c) nEOFSeq >> hFlush (handle c) where lines' :: ByteString -> [ByteString] lines' x | B.length (snd b) > 1 = s:(lines' $ snd b) | otherwise = [fst b] where b = B.breakSubstring nEOLSeq x postize :: ByteString -> ByteString postize x | B.length x /= 0 && B.head x == '.'= cons '.' x | otherwise = x cGetLine :: Connection -> IO ByteString cGetLine c = f =<< hGetLine (handle c) where f l | B.length l == 0 = aEOL `fmap` cGetLine c | B.last l == '\r' = return $ B.init l | otherwise = laEOL `fmap` cGetLine c where aEOL = (hEOLSeq `append`) laEOL = (l `append` hEOLSeq `append`) cGetText :: Connection -> (ByteString -> IO a) -> IO [a] cGetText c f = process =<< cGetLine c where process l = if B.length l == 1 && B.head l == '.' then return [] else liftM2 (:) (f depost) $ cGetText c f where depost = if unpack (B.take 2 l) == ".." then B.tail l else l