module Network.NNTP.Internal
(
Article(..),
Group(..),
NntpT(..),
NntpState(..),
NntpConnection(..),
NntpError(..),
NntpParser,
runNntpParser,
nntpPutStr,
nntpPutStrLn,
nntpSendCommand,
tryCommands
)
where
import Control.Applicative hiding (empty)
import Control.Arrow
import Control.Monad.Error
import Control.Monad.State hiding (State)
import Data.ByteString.Lazy.Char8 hiding (foldl)
import Data.Monoid
import Text.Parsec hiding ((<|>), many)
import Text.Parsec.Pos
data Article = Article {
articleID :: String,
articleHeader :: Maybe ByteString,
articleBody :: Maybe ByteString
}
instance Show Article where
show = ("Article "++) . articleID
instance Eq Article where
(==) = curry (articleID *** articleID >>> uncurry (==))
data Group = Group {
groupName :: String,
groupArticleFirst :: Integer,
groupArticleLast :: Integer
}
instance Show Group where
show = ("Group "++) . groupName
instance Eq Group where
(==) = curry (groupName *** groupName >>> uncurry (==))
data Monad m => NntpConnection m = NntpConnection {
input :: ByteString,
output :: ByteString -> m ()
}
data Monad m => NntpState m = NntpState {
connection :: NntpConnection m
}
data Monad m => NntpT m a = NntpT {
runNntpT :: StateT (NntpState m) (ErrorT NntpError m) a
}
instance Monad m => Applicative (NntpT m) where
pure = return
(<*>) = ap
instance Monad m => Functor (NntpT m) where
f `fmap` m = NntpT $ f <$> runNntpT m
instance Monad m => Monad (NntpT m) where
m >>= f = NntpT $ runNntpT m >>= runNntpT . f
return = lift . return
instance MonadTrans NntpT where
lift = NntpT . lift . lift
instance MonadIO m => MonadIO (NntpT m) where
liftIO = lift . liftIO
data NntpError = NoSuchGroup
| NoSuchArticle
| PostingFailed
| PostingNotAllowed
| ServiceDiscontinued
| NoSuchCommand
deriving (Eq, Show, Read)
instance Error NntpError where
noMsg = undefined
strMsg = read
type NntpParser m a = ParsecT ByteString () (NntpT m) a
runNntpParser :: Monad m => NntpParser m a -> NntpT m a
runNntpParser p = do s <- NntpT (gets $ input . connection)
r <- parserRep =<< runParsecT p
(State s (initialPos "") ())
case r of
Ok v (State i _ _) _ -> NntpT (modify $ pNI i) >>
return v
Error e -> error $ show e
where parserRep (Consumed x) = x
parserRep (Empty x) = x
pNI i s = s {connection = (connection s) {input = i}}
nntpPutStr :: Monad m => ByteString -> NntpT m ()
nntpPutStr s = lift . ($ s) =<< NntpT (gets $ output . connection)
nntpPutStrLn :: Monad m => ByteString -> NntpT m ()
nntpPutStrLn = nntpPutStr . (`mappend` pack "\r\n")
nntpSendCommand :: Monad m => String
-> ByteString
-> NntpParser m a
-> NntpT m a
nntpSendCommand c a p = nntpPutStrLn (pack (c ++ " ") `mappend` a) >>
runNntpParser p
tryCommands :: Monad m => [NntpT m a]
-> NntpT m a
tryCommands = foldl (\a b -> NntpT $ runNntpT a `catchError`
\e -> if e == NoSuchCommand
then runNntpT b else throwError e)
(NntpT $ throwError NoSuchCommand)