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
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.Internal.Article
import Network.NNTP.Internal.Group
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 =
snd `liftM`
runNntpT (liftM2 const (f =<< runNntpParser cHelo) (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 $ \s -> return $! (s, Left 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 $ \s -> return $! (s, Left 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 $ \s -> return $! (s, Left NoSuchArticle)) return
fetchArticleHeader :: Monad m => Article
-> NntpT m Article
fetchArticleHeader a = Core.head (pack $ articleID a) >>=
maybe (NntpT $ \s -> return $! (s, Left NoSuchArticle))
(\a' -> return $! a {articleHeader = articleHeader a'})
fetchArticleBody :: Monad m => Article
-> NntpT m Article
fetchArticleBody a = Core.body (pack $ articleID a) >>=
maybe (NntpT $ \s -> return $! (s, Left 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 $ \s -> return $! (s, Left 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"