{- |
Module      : $Header$
Description : Internalities of NNTP modules
Copyright   : (c) Maciej Piechotka
License     : LGPL 3 or later

Maintainer  : uzytkownik2@gmail.com
Stability   : none
Portability : portable

This module contains internalities of NNTP library
-}
module Network.NNTP.Internal
    (
     -- * Types
     NntpT(..),
     NntpState(..),
     NntpConnection(..),
     NntpError(..),
     NntpParser,
     -- * Functions
     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

{- |
NntpConnection represents a connection in a NntpT monad.

Please note that for 'runNntpWithConnection' you need to supply both 'input'
and 'output' functions.
-}
data NntpConnection m = NntpConnection {
      -- | Input is an stream which is from a server.
      input :: ByteString,
      -- | Output is a function which sends the data to a server.
      output :: ByteString -> m ()
    }
{- |
NntpState represents a state at given moment. Please note that this type is not
a part of stable API (when we will have one).
-}
data NntpState m = NntpState {
      connection :: NntpConnection m
    }
{- |
NntpT represents a connection. Since some servers have short timeouts it is
recommended to keep the connections short.
-}
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 ())

{- |
Indicates an error of handling NNTP connection. Please note that this should
indicate client errors only (with the exception of 'ServiceDiscontinued', 
in some cases 'PostingFailed' and 'NoSuchCommand'. The last one if propagated
outside NNTP module indicates a bug in library or server.).
-}
data NntpError = NoSuchGroup
               -- ^ Indicates that operation was performed on group that does
               -- not exists.
               | NoSuchArticle
               -- ^ Indicates that operation was performed on article that does
               --  not exists.
               | PostingFailed
               -- ^ Indicates that posting operation failed for some reason.
               | PostingNotAllowed
               -- ^ Indicates that posting is not allowed.
               | ServiceDiscontinued
               -- ^ Indicates that service was discontinued.
               | NoSuchCommand
               -- ^ Indicates that command does not exists.
               deriving (Eq, Show, Read)

type NntpParser m a = ParsecT ByteString () (NntpT m) a
-- | Transforms "NntpParser" into "NntpT" monad taking care about input
-- position
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}}
-- | Puts an argument to output.
nntpPutStr :: Monad m => ByteString -> NntpT m ()
nntpPutStr s = lift . ($ s) =<< getsNNTP (output . connection)
-- | Puts an argument to output followed by end-of-line.
nntpPutStrLn :: Monad m => ByteString -> NntpT m ()
nntpPutStrLn = nntpPutStr . (`mappend` pack "\r\n")
-- | Sends a command.
nntpSendCommand :: Monad m => String -- ^ Command.
               -> ByteString -- ^ Arguments.
               -> [(Int, NntpParser m a)] -- ^ Parser of output.
               -> NntpT m a -- ^ Returned value from parser.
nntpSendCommand c a p = runNntpParser $ nntpPSendCommand c a p
-- | Sends text
nntpSendText :: Monad m => ByteString -- ^ Text
             -> [(Int, NntpParser m a)] -- ^ Parser of output.
             -> NntpT m a -- ^ Returned value from parser.
nntpSendText t p = runNntpParser $ nntpPSendText t p
-- | Sends a command.
nntpPSendCommand :: Monad m => String -- ^ Command.
                -> ByteString -- ^ Arguments.
                -> [(Int, NntpParser m a)] -- ^ Parser of output.
                -> NntpParser m a -- ^ Returned value from parser.
nntpPSendCommand c a p = nntpPSend (pack (c ++ " ") `mappend` a) p
-- | Sends text
nntpPSendText :: Monad m => ByteString -- ^ Text
              -> [(Int, NntpParser m a)] -- ^ Parser of output.
              -> NntpParser m a -- ^ Returned value from parser.
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)))])
-- | Try commands one by one to check for existing command.
tryCommands :: Monad m => [NntpT m a] -- ^ Possible command.
            -> NntpT m a -- ^ Result
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
-- | Converts into postable form.
postize :: ByteString -> ByteString
postize = BS.drop 2 . replace (pack "\r\n.") (pack "\r\n..") .
          append (pack "\r\n")
-- | Converts from postable form
depostize :: ByteString -> ByteString
depostize = BS.drop 2 . replace (pack "\r\n..") (pack "\r\n.") .
            append (pack "\r\n")