module Network.NNTP.Internal
(
NntpT(..),
NntpState(..),
NntpConnection(..),
NntpError(..),
NntpParser,
runNntpParser,
nntpPutStr,
nntpPutStrLn,
nntpSendCommand,
nntpSendText,
nntpPSendCommand,
nntpPSendText,
tryCommands,
postize,
depostize
)
where
import Control.Applicative hiding (empty)
import Control.Monad
import Control.Monad.Trans
import Data.ByteString.Lazy.Char8 as BS hiding (foldl,replicate)
import Data.Maybe
import Data.Monoid
import Text.Parsec hiding ((<|>), many)
import Text.Parsec.Pos
data NntpConnection m = NntpConnection {
input :: ByteString,
output :: ByteString -> m ()
}
data NntpState m = NntpState {
connection :: NntpConnection m
}
newtype NntpT m a = NntpT {
runNntpT :: NntpState m -> m (NntpState m, Either NntpError a)
}
instance Functor m => Functor (NntpT m) where
f `fmap` m = NntpT $ \s ->
(\(s', v) -> (s', either Left (Right . f) v)) <$> runNntpT m s
instance (Functor m, Monad m) => Applicative (NntpT m) where
pure = return
(<*>) = ap
instance Monad m => Monad (NntpT m) where
m >>= f = NntpT $ \s -> do (s', v) <- runNntpT m s
case v of
Left e -> return $! (s, Left e)
Right a -> runNntpT (f a) s'
return x = NntpT $ \s -> return $! (s, Right x)
instance MonadTrans NntpT where
lift m = NntpT $ \s -> (\v -> (s, Right v)) `liftM` m
getsNNTP :: Monad m => (NntpState m -> a) -> NntpT m a
getsNNTP f = NntpT $ \s -> return $! (s, Right $! f s)
modifyNNTP :: Monad m => (NntpState m -> NntpState m) -> NntpT m ()
modifyNNTP f = NntpT $ \s -> return $! (f s, Right ())
data NntpError = NoSuchGroup
| NoSuchArticle
| PostingFailed
| PostingNotAllowed
| ServiceDiscontinued
| NoSuchCommand
deriving (Eq, Show, Read)
type NntpParser m a = ParsecT ByteString () (NntpT m) a
runNntpParser :: Monad m => NntpParser m a -> NntpT m a
runNntpParser p = do s <- getsNNTP $ input . connection
r <- parserRep =<< runParsecT p
(State s (initialPos "") ())
case r of
Ok v (State i _ _) _ -> modifyNNTP (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) =<< getsNNTP (output . connection)
nntpPutStrLn :: Monad m => ByteString -> NntpT m ()
nntpPutStrLn = nntpPutStr . (`mappend` pack "\r\n")
nntpSendCommand :: Monad m => String
-> ByteString
-> [(Int, NntpParser m a)]
-> NntpT m a
nntpSendCommand c a p = runNntpParser $ nntpPSendCommand c a p
nntpSendText :: Monad m => ByteString
-> [(Int, NntpParser m a)]
-> NntpT m a
nntpSendText t p = runNntpParser $ nntpPSendText t p
nntpPSendCommand :: Monad m => String
-> ByteString
-> [(Int, NntpParser m a)]
-> NntpParser m a
nntpPSendCommand c a p = nntpPSend (pack (c ++ " ") `mappend` a) p
nntpPSendText :: Monad m => ByteString
-> [(Int, NntpParser m a)]
-> NntpParser m a
nntpPSendText t p = nntpPSend (postize t) p
nntpPSend :: Monad m => ByteString -> [(Int, NntpParser m a)] -> NntpParser m a
nntpPSend t p = do
lift $ nntpPutStr t
c <- read <$> sequence (replicate 3 digit)
fromMaybe (error "Unknown response") $ lookup c $ appendCommon p
appendCommon :: Monad m => [(Int, NntpParser m a)] -> [(Int, NntpParser m a)]
appendCommon =
(++ [(400, many1 space *> lift (NntpT $ \s -> return $! (s, Left ServiceDiscontinued))),
(500, many1 space *> lift (NntpT $ \s -> return $! (s, Left NoSuchCommand)))])
tryCommands :: Monad m => [NntpT m a]
-> NntpT m a
tryCommands = foldl (\a b -> NntpT $ \s -> do
(s', v) <- runNntpT a s
case v of
Right v' -> return $! (s, Right v')
Left NoSuchCommand -> runNntpT b s'
Left e -> return $! (s', Left e))
(NntpT $ \s -> return $! (s, Left NoSuchCommand))
replace :: ByteString -> ByteString -> ByteString -> ByteString
replace f t i = if f `isPrefixOf` i
then t `append` replace f t (BS.drop (BS.length f) i)
else if BS.null i
then empty
else replace f t $ BS.tail t
postize :: ByteString -> ByteString
postize = BS.drop 2 . replace (pack "\r\n.") (pack "\r\n..") .
append (pack "\r\n")
depostize :: ByteString -> ByteString
depostize = BS.drop 2 . replace (pack "\r\n..") (pack "\r\n.") .
append (pack "\r\n")