module Network.NNTP
(
Article(..),
Group(..),
NntpConnection(..),
NntpState(..),
NntpT(..),
NntpError(..),
runNntpWithHost,
runNntpWithConnection,
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.Loops
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)
runNntpWithHost :: MonadIO m => String
-> Maybe Word16
-> (Bool -> NntpT m a)
-> m (Either NntpError a)
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
runNntpWithConnection :: Monad m => NntpConnection m
-> (Bool -> NntpT m a)
-> m (Either NntpError a)
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
articleFromID :: Monad m => String
-> NntpT m (Maybe Article)
articleFromID = Core.stat . pack
articleFromNo :: Monad m => Group
-> Integer
-> NntpT m (Maybe Article)
articleFromNo g n = Core.group (pack $ groupName g) >>=
maybe (NntpT $ throwError NoSuchGroup)
(const $ Core.stat $ pack $ show n)
groupFromName :: Monad m => String
-> NntpT m (Maybe Group)
groupFromName = Core.group . pack
forGroups :: Monad m => (Group -> m a)
-> NntpT m [a]
forGroups = Core.list
forNewGroups :: Monad m => UTCTime
-> (Group -> m a)
-> NntpT m [a]
forNewGroups = Core.newgroups
forArticles :: Monad m => Group
-> (Article -> m a)
-> NntpT m [a]
forArticles g f =
Core.group (pack $ groupName g) >>=
flip when (NntpT $ throwError NoSuchGroup) . isNothing >>
tryCommands [Common.xhdr f,
Core.stat empty >>=
liftMb (lift . f >=>
\s -> unfoldM (Core.next >>= liftMb (lift . f)) >>=
\r -> return (s:r)) >>=
return . fromMaybe []]
where liftMb :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b))
liftMb h = maybe (return Nothing) (return . Just <=< h)
forNewArticles :: Monad m => UTCTime
-> Group
-> (Article -> m a)
-> NntpT m [a]
forNewArticles = Core.newnews
fetchArticle :: Monad m => Article
-> NntpT m Article
fetchArticle = Core.article . pack . articleID >=>
maybe (NntpT $ throwError NoSuchArticle) return
fetchArticleHeader :: Monad m => Article
-> NntpT m Article
fetchArticleHeader a = Core.head (pack $ articleID a) >>=
maybe (NntpT $ throwError NoSuchArticle)
(\a' -> return $ a {articleHeader = articleHeader a'})
fetchArticleBody :: Monad m => Article
-> NntpT m Article
fetchArticleBody a = Core.body (pack $ articleID a) >>=
maybe (NntpT $ throwError NoSuchArticle)
(\a' -> return $ a {articleBody = articleBody a'})
fetchArticleLazy :: Monad m => Article
-> NntpT m 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
fetchArticleHeaderLazy :: Monad m => Article
-> NntpT m Article
fetchArticleHeaderLazy a@(Article _ Nothing _) = fetchArticleHeader a
fetchArticleHeaderLazy a@(Article _ _ _) = return a
fetchArticleBodyLazy :: Monad m => Article
-> NntpT m Article
fetchArticleBodyLazy a@(Article _ _ Nothing) = fetchArticleBody a
fetchArticleBodyLazy a@(Article _ _ _ ) = return a
fetchGroup :: Monad m => Group
-> NntpT m Group
fetchGroup = maybe (NntpT $ throwError NoSuchGroup) return <=<
Core.group . pack . groupName
post :: Monad m => ByteString
-> 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"