{- | Module : $Header$ Description : Basic NNTP data types Copyright : (c) Maciej Piechotka License : LGPL 3 or later Maintainer : uzytkownik2@gmail.com Stability : none Portability : portable This module contains the common features and common interface. -} module Network.NNTP ( -- * Types Article(..), Group(..), NntpConnection(..), NntpState(..), NntpT(..), -- * Errors NntpError(..), -- * Functions -- ** 'NntpState'-related functions runNntpWithHost, runNntpWithConnection, -- ** Commands functions articleFromID, articleFromNo, groupFromName, forGroups, forNewGroups, forArticles, forNewArticles, fetchArticle, fetchArticleHeader, fetchArticleBody, fetchArticleLazy, fetchArticleHeaderLazy, fetchArticleBodyLazy, fetchGroup, post ) where import Control.Applicative hiding (empty) import Control.Monad.Error import Control.Monad.State hiding (State) import Control.Monad.Trans import Data.ByteString.Lazy.Char8(ByteString, empty, hGetContents, hPut, pack) import Data.Maybe import Data.Time import Data.Word import qualified Network.NNTP.Core as Core import qualified Network.NNTP.Common as Common import Network.NNTP.Internal import Network.NNTP.ParserHelpers hiding (groupName) import Network.Socket import System.IO hiding (hGetContents) -- | This is utility function which connects to a host, creates 'NntpState' and -- supplies it to 'runNntpWithState'. runNntpWithHost :: MonadIO m => String -- ^ A hostname. -> Maybe Word16 -- ^ Port. 'Nothing' for standard port. -> (Bool -> NntpT m a) -- ^ Function returning 'NntpT' monad. -- Argument indicates if posting is -- allowed. -> m (Either NntpError a) -- ^ Returned value. runNntpWithHost h p f = do s <- liftIO $ connectToHost h $ maybe "nntp" show p ha <- liftIO $ socketToHandle s ReadWriteMode liftIO $ hSetBuffering ha LineBuffering o <- liftIO $ hGetContents ha let c = NntpConnection o (liftIO . (hPut ha >=> \_ -> hFlush ha)) runNntpWithConnection c f -- | Runs Nntp with given connection. runNntpWithConnection :: Monad m => NntpConnection m -- ^ A state -> (Bool -> NntpT m a) -- ^ Function returning 'NntpT' -- monad. Argument indicates if -- posting is allowed. -> m (Either NntpError a) -- ^ Returned value. runNntpWithConnection c f = runErrorT $ return . fst =<< runStateT (runNntpT ((runNntpParser cHelo >>= f) <* runNntpParser cQuit)) (NntpState c) connectToHost :: String -> String -> IO Socket connectToHost h p = do a <- head <$> getAddrInfo Nothing (Just h) (Just p) s <- socket (addrFamily a) Stream 0 connect s (addrAddress a) return s -- | Returns the Article for given ID. Please note that it may or may not -- fetch the header and body. Preferred is lazy loading. articleFromID :: Monad m => String -- ^ ID of article. -> NntpT m (Maybe Article) -- ^ Returns the article. articleFromID = Core.stat . pack -- | Returns the Article of given number from given Group. Please note that -- it may or may not fetch the header and body. Preferred is lazy loading. articleFromNo :: Monad m => Group -- ^ Group. -> Integer -- ^ ID of article. -> NntpT m (Maybe Article) -- ^ Returns the article. articleFromNo g n = Core.group (pack $ groupName g) >>= maybe (NntpT $ throwError NoSuchGroup) (const $ Core.stat $ pack $ show n) -- | Returns the Group of given name. groupFromName :: Monad m => String -- ^ Name of group. -> NntpT m (Maybe Group) -- ^ Group. groupFromName = Core.group . pack -- | Iterates over every group on server collecting values. Please note -- that the function may be called before all I/O operations finished and -- the implementation may or may not allaw to call other NNTP functions -- during the call. forGroups :: Monad m => (Group -> m a) -- ^ Function called each time. -> NntpT m [a] -- ^ Collected values. forGroups = Core.list -- | Iterates over new group on server collecting values. Please note -- that the function may be called before all I/O operations finished and -- the implementation may or may not allaw to call other NNTP functions -- during the call. forNewGroups :: Monad m => UTCTime -- ^ Groups only newer thet this time will -- be returned. -> (Group -> m a) -- ^ Function called each time. -> NntpT m [a] -- ^ Collected values. forNewGroups = Core.newgroups -- | Iterates over the articles in group collecting values. Please note -- that the function may be called before all I/O operations finished and -- the implementation may or may not allaw to call other NNTP functions -- during the call. forArticles :: Monad m => Group -- ^ Group which we iterate. -> (Article -> m a) -- ^ Function called each time. -> NntpT m [a] -- ^ Collected values. forArticles g f = Core.group (pack $ groupName g) >>= maybe (NntpT $ throwError NoSuchGroup) (\_ -> tryCommands [Common.xhdr f, stat]) where stat = Core.stat empty >>= process process Nothing = return [] process (Just a) = liftM2 (:) (lift $ f a) (Core.next >>= process) -- | Iterates over the new articles in group collecting values. Please note -- that the function may be called before all I/O operations finished and -- the implementation may or may not allaw to call other NNTP functions -- during the call. forNewArticles :: Monad m => UTCTime -- ^ Articles only newer thet this time -- will be returned. -> Group -- ^ Group which we iterate. -> (Article -> m a) -- ^ Function called each time. -> NntpT m [a] -- ^ Collected values. forNewArticles = Core.newnews -- | Fetch the article. fetchArticle :: Monad m => Article -- ^ An article. -> NntpT m Article -- ^ Updated article. fetchArticle = Core.article . pack . articleID >=> maybe (NntpT $ throwError NoSuchArticle) return -- | Fetch the article header. fetchArticleHeader :: Monad m => Article -- ^ An article. -> NntpT m Article -- ^ Updated article. fetchArticleHeader a = Core.head (pack $ articleID a) >>= maybe (NntpT $ throwError NoSuchArticle) (\a' -> return $ a {articleHeader = articleHeader a'}) -- | Fetch the article header. fetchArticleBody :: Monad m => Article -- ^ An article. -> NntpT m Article -- ^ Updated article. fetchArticleBody a = Core.body (pack $ articleID a) >>= maybe (NntpT $ throwError NoSuchArticle) (\a' -> return $ a {articleBody = articleBody a'}) -- | Fetchs the article only if it is not fetched. fetchArticleLazy :: Monad m => Article -- ^ An article. -> NntpT m Article -- ^ Updated article. fetchArticleLazy a@(Article _ Nothing Nothing) = fetchArticle a fetchArticleLazy a@(Article _ _ Nothing) = fetchArticleBody a fetchArticleLazy a@(Article _ Nothing _ ) = fetchArticleHeader a fetchArticleLazy a@(Article _ _ _ ) = return a -- | Fetchs the article header if it is not fetched. fetchArticleHeaderLazy :: Monad m => Article -- ^ An article. -> NntpT m Article -- ^ Updated article. fetchArticleHeaderLazy a@(Article _ Nothing _) = fetchArticleHeader a fetchArticleHeaderLazy a@(Article _ _ _) = return a -- | Fetchs the article body if it is not fetched. fetchArticleBodyLazy :: Monad m => Article -- ^ An article. -> NntpT m Article -- ^ Updated article. fetchArticleBodyLazy a@(Article _ _ Nothing) = fetchArticleBody a fetchArticleBodyLazy a@(Article _ _ _ ) = return a -- | Updates group. fetchGroup :: Monad m => Group -- ^ A group. -> NntpT m Group -- ^ Updated group. fetchGroup = maybe (NntpT $ throwError NoSuchGroup) return <=< Core.group . pack . groupName -- | Posts an article. post :: Monad m => ByteString -- ^ Article contents -> NntpT m () post = Core.post cHelo :: Monad m => NntpParser m Bool cHelo = (code <* line) >>= \l -> case l of 200 -> return True 201 -> return False _ -> error "Unknown response" cQuit :: Monad m => NntpParser m () cQuit = do lift $ nntpPutStrLn $ pack "QUIT" c <- code <* line case c of 205 -> return () _ -> error "Unknown response"