module Network.NNTP.Core
(
article,
Network.NNTP.Core.head,
body,
stat,
group,
Network.NNTP.Core.last,
list,
newgroups,
newnews,
next,
post
)
where
import Control.Applicative hiding (empty)
import Control.Arrow
import Control.Monad.Error
import Data.ByteString.Lazy.Char8(ByteString, empty, pack)
import Data.Time
import Network.NNTP.Internal hiding (groupName)
import Network.NNTP.ParserHelpers
import System.Locale
import Text.Parsec hiding ((<|>))
article :: Monad m => ByteString -> NntpT m (Maybe Article)
article s = nntpSendCommand "ARTICLE" s $ articleCommon HeadAndBody
head :: Monad m => ByteString -> NntpT m (Maybe Article)
head s = nntpSendCommand "HEAD" s $ articleCommon Head
body :: Monad m => ByteString -> NntpT m (Maybe Article)
body s = nntpSendCommand "BODY" s $ articleCommon Body
stat :: Monad m => ByteString -> NntpT m (Maybe Article)
stat s = nntpSendCommand "STAT" s $ articleCommon Nil
group :: Monad m => ByteString -> NntpT m (Maybe Group)
group s = nntpSendCommand "GROUP" s $ do
c <- code <* many1 spaces
case c of
211 -> do f <- (integer >> many1 spaces) *> integer <*
many1 spaces
l <- integer <* many1 spaces
g <- groupName <* line
return $ Just $ Group g f l
411 -> return Nothing
_ -> error "Unknown response"
last :: Monad m => NntpT m (Maybe Article)
last = nntpSendCommand "LAST" empty $ articleCommon Nil
list :: Monad m => (Group -> m a) -> NntpT m [a]
list f = nntpSendCommand "LIST" empty $ cNewsgroupList f
newgroups :: Monad m => UTCTime -> (Group -> m a) -> NntpT m [a]
newgroups t f = nntpSendCommand "NEWGROUPS" (pack $ sh t) $ cNewsgroupList f
where sh = formatTime defaultTimeLocale "%y%m%d %H%M%S GMT"
newnews :: Monad m => UTCTime -> Group -> (Article -> m a) -> NntpT m [a]
newnews = undefined
next :: Monad m => NntpT m (Maybe Article)
next = nntpSendCommand "NEXT" empty $ articleCommon Nil
post :: Monad m => ByteString -> NntpT m ()
post p = do nntpPutStrLn $ pack "POST"
l <- runNntpParser $ code <* line
case l of
340 -> return ()
440 -> NntpT $ throwError PostingNotAllowed
_ -> error "Unknown response"
nntpPutStrLn p
l' <- runNntpParser $ code <* line
case l' of
240 -> return ()
441 -> NntpT $ throwError PostingFailed
_ -> error "Unknown response"
data ArticleReq = HeadAndBody
| Head
| Body
| Nil
articleCommon :: Monad m => ArticleReq -> NntpParser m (Maybe Article)
articleCommon r = do
rn <- code
case rn of
412 -> error "No group selected"
420 -> error "No current article"
421 -> return Nothing
422 -> return Nothing
423 -> return Nothing
430 -> return Nothing
_ -> if not $ rn `elem` correct
then error "Unknown response"
else if articleReq2Int r /= rn
then error "Incorrect response"
else do
many1 spaces >> integer >> many1 spaces
i <- iD <* line
case r of
HeadAndBody -> Just <$> liftM (uncurry (Article i))
((Just *** Just) <$> cHeadAndBody)
Head -> Just <$> liftM2 (Article i) (Just <$> text)
(pure Nothing)
Body -> Just <$> liftM (Article i Nothing) (Just <$> text)
Nil -> return $ Just $ Article i Nothing Nothing
where correct = [220, 221, 222, 223]
articleReq2Int HeadAndBody = 220
articleReq2Int Head = 221
articleReq2Int Body = 222
articleReq2Int Nil = 223
cNewsgroupList :: Monad m => (Group -> m a) -> NntpParser m [a]
cNewsgroupList f = do c <- code <* line
case c of
215 -> readGroups
_ -> error "Unknown response"
where readGroups = try (string ".\r\n" >> return []) <|>
liftM2 (:) (lift . lift . f =<<
(do n <- groupName <*
many1 space
l <- integer <*
many1 space
fi <- integer <* line
return $ Group n fi l))
readGroups
cHeadAndBody :: Monad m => NntpParser m (ByteString, ByteString)
cHeadAndBody = liftM2 (,) (pack <$> (anyChar `manyTill` try eoh)) text
where eoh = string "\r\n\r\n"