{- |
Module      : $Header$
Description : RFC977 implementation (which is the most popular version).
Copyright   : (c) Maciej Piechotka
License     : LGPL 3 or later

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

RFC977 is the most popular version of protocol.
-}
module Network.NNTP.RFC977
    (
     -- * Types
     Connection,
     -- * Functions
     joinToSocket,
     joinToHandle,
     connectToHost,
    )
    where
import Control.Arrow
import Control.Exception(Exception,throw)
import Control.Monad
import Data.ByteString.Char8 as B
import Data.Maybe
import Data.Time
import Data.Word
import Locale
import Network.Socket
import Network.NNTP hiding (Connection)
import qualified Network.NNTP(Connection)
import Prelude as P
import System.IO hiding (hGetLine,hPutStr)

{- |
An RFC977 connection.
-}
data Connection = Connection {
      handle :: System.IO.Handle
    }

-- | Usage existing Socket and creating from it connection.
joinToSocket :: Socket -- ^ The existing socket
             -> IO (Connection, Bool) -- ^ Returns connection and a bool
                                      -- indicating if posting is allowed
joinToSocket = flip socketToHandle ReadWriteMode >=> joinToHandle

-- | Usage existing Handle and creating from it connection.
joinToHandle :: System.IO.Handle -- ^ Existing handle
             -> IO (Connection, Bool) -- ^ Returns connection and a bool
                                      -- indicating if posting is allowed
joinToHandle h = do let c = Connection h
                    hSetBuffering h LineBuffering
                    l <- cGetLine c
                    case (B.unpack $ B.take 3 l) of
                      "200" -> return (c, True)
                      "201" -> return (c, False)
                      _ -> error "Unknown response"

-- | Connects to NNTP server
connectToHost :: String -- ^ A server name
              -> Maybe Word16 -- ^ Server port. Nothing indicates default
              -> IO (Connection, Bool) -- ^ Returns connection and a bool
                                       -- indicating if posting is allowed
connectToHost = curry $ runKleisli c2H
                where c2H = second (arr (fromMaybe "nntp" . fmap show)) >>>
                            arr (Just *** Just) >>>
                            Kleisli (uncurry (getAddrInfo Nothing)) >>>
                            arr P.head >>>
                            (Kleisli ai2socket) &&& (arr addrAddress) >>>
                            Kleisli (\(s, a) -> connect s a >> return s) >>>
                            Kleisli joinToSocket
                      ai2socket ai = socket (addrFamily ai) Stream 0

instance Network.NNTP.Connection Connection where
     articleFromID c i = stat c i
     articleFromNo c g i = fetchGroup c g >> stat c (show i)
     groupFromName c n = _group c n
  
     forGroups = list
     forNewGroups = newgroups
     forArticles c g f = fetchGroup c g >> stat c "" >>= process
                         where getNext = next c >>= process
                               process Nothing = return []
                               process (Just a) = do v <- f a
                                                     r <- getNext
                                                     return $ v:r
     forNewArticles = newnews
     
     fetchArticle c a = article c (articleID a) >>= justOrThrowM NoSuchArticle
     fetchArticleHeader c a = na `fmap` (justOrThrowM NoSuchArticle =<< h)
                              where i = articleID a
                                    b = articleBody a
                                    na a' = Article i (articleHeader a') b
                                    h = Network.NNTP.RFC977.head c i
     fetchArticleBody c a = na `fmap` (justOrThrowM NoSuchArticle =<< body c i)
                            where i = articleID a
                                  h = articleHeader a
                                  na a' = Article i h (articleBody a')
     fetchGroup c g = justOrThrowM NoSuchGroup =<< _group c (groupName g)
     post = Network.NNTP.RFC977.post
     disconnect = quit

article :: Connection -> String -> IO (Maybe Article)
article c i = cSendCommand c ("ARTICLE" ++ i) $ articleCommandH 220 c
head :: Connection -> String -> IO (Maybe Article)
head c i = cSendCommand c ("HEAD " ++ i) $ articleCommandH 221 c
body :: Connection -> String -> IO (Maybe Article)
body c i = cSendCommand c ("BODY " ++ i) $ articleCommandH 222 c
stat :: Connection -> String -> IO (Maybe Article)
stat c i = cSendCommand c ("STAT " ++ i) $ articleCommandH 223 c
_group :: Connection -> String -> IO (Maybe Group)
_group c n = cSendCommand c ("GROUP " ++ n) groupCommandH'
             where groupCommandH' 211 s = return $ Just $ createGroup s
                   groupCommandH' 411 _ = return Nothing
                   groupCommandH' _ _ = error "Unknown response"
                   createGroup s = Group (w!!3)
                                         (read (w!!1)) (read (w!!2))
                                   where w = P.words $ unpack s
--last :: Connection -> IO (Maybe Article)
--last c = cSendCommand c "LAST" $ articleCommandH 223 c
list :: Connection -> (Group -> IO a) -> IO [a]
list c f = cSendCommand c "LIST" $ groupCommandH c f
newgroups :: Connection -> UTCTime -> (Group -> IO a) -> IO [a]
newgroups c t f = cSendCommand c ("NEWGROUPS " ++ (pTime t) ++ " GMT") $ ngH
                  where ngH = groupCommandH c f
newnews :: Connection -> Group -> UTCTime -> (Article -> IO a) -> IO [a]
newnews c g t f = cSendCommand c ("NEWNEWS " ++ s ++ " GMT") nnH
                  where nnH 239 _ = cGetText c (f . createArticle)
                        nnH 400 _ = throw ServiceDiscontinued
                        nnH _ _ = error "Unknown response"
                        s :: String
                        s = (groupName g) ++ (pTime t)
                        createArticle :: ByteString -> Article
                        createArticle st = Article (unpack st) Nothing Nothing
next :: Connection -> IO (Maybe Article)
next c = cSendCommand c "NEXT" $ articleCommandH 223 c
post :: Connection -> ByteString -> IO ()
post c p = cSendCommand c "POST" postH
           where postH 340 _ = cPutText c p >> cGetLine c >>= check
                               where check = checkS . P.take 3 . unpack
                                     checkS "240" = return ()
                                     checkS "400" = throw ServiceDiscontinued
                                     checkS "441" = throw PostingFailed
                                     checkS _ = error "Unknown response"
                 postH 400 _ = throw ServiceDiscontinued
                 postH 440 _ = throw PostingNotAllowed
                 postH _ _ = error "Unknown response"
quit :: Connection -> IO ()
quit c = cSendCommand c "QUIT" quitH
         where quitH 205 _ = return ()
               quitH 400 _ = throw ServiceDiscontinued
               quitH _ _ = error "Unknown response"

pTime :: UTCTime -> String
pTime = formatTime defaultTimeLocale "%y%m%d %H%M%S"

articleCommandH :: Int -> Connection -> Int -> ByteString -> IO (Maybe Article)
articleCommandH e c r i
  | e == r     = case r of
                   220 -> p2A `fmap` getContentA
                   221 -> h2A `fmap` getContent
                   222 -> b2A `fmap` getContent
                   223 -> return $ Just $ Article aID Nothing Nothing
                   _ -> error "Internal error: unknown expected response"
  | r == 412   = error "Internal error: no group selected"
  | r == 420   = error "Internal error: no article selected"
  | r == 421   = return Nothing
  | r == 422   = return Nothing
  | r == 423   = return Nothing
  | r == 430   = return Nothing
  | r == 440   = throw ServiceDiscontinued
  | otherwise  = error "Unknown response"
                 where aID = (P.words $ B.unpack i)!!1
                       p2A = Just <<< uncurry (Article aID) <<<
                             (justJoin *** justJoin)
                       h2A = Just . flip (Article aID) Nothing . Just
                       b2A = Just . Article aID Nothing . Just
                       getContent = B.concat `fmap` cGetText c return
                       getContentA = P.span (==empty) `fmap` cGetText c return
                       justJoin = Just . intercalate nEOFSeq
groupCommandH :: Connection -> (Group -> IO a) -> Int -> ByteString -> IO [a]
groupCommandH c f 215 _ = cGetText c (f . createGroup)
                          where createGroup s = Group (w!!0)
                                                      (read (w!!2))
                                                      (read (w!!3))
                                                where w = P.words $ unpack s
groupCommandH _ _ 400 _ = throw ServiceDiscontinued
groupCommandH _ _ _ _ = error "Unknown response"

cSendCommand :: Connection -> String -> (Int -> ByteString -> IO a) -> IO a
cSendCommand c k f = cPutLine c (pack k) >> 
                     cGetLine c >>= (id &&& id >>>
                                     read . unpack . B.take 3 *** B.drop 4 >>>
                                     uncurry f)

justOrThrowM :: (Monad m, Exception b) => b -> Maybe a -> m a
justOrThrowM _ (Just x) = return x
justOrThrowM e Nothing = throw e

hEOLSeq :: ByteString
hEOLSeq = singleton '\n'
nEOLSeq :: ByteString
nEOLSeq = pack "\r\n"
nEOFSeq :: ByteString
nEOFSeq = pack "\r\n.\r\n"

cPutLine :: Connection -> ByteString -> IO ()
cPutLine c s = hPutStr (handle c) s >> hPutStr (handle c) nEOLSeq
               >> hFlush (handle c)
cPutText :: Connection -> ByteString -> IO ()
cPutText c s = mapM_ (cPutLine c) (P.map postize (lines' s)) >>
               hPutStr (handle c) nEOFSeq >> hFlush (handle c)
               where lines' :: ByteString -> [ByteString]
                     lines' x | B.length (snd b) > 1 = s:(lines' $ snd b)
                              | otherwise            =  [fst b]
                              where b = B.breakSubstring nEOLSeq x
                     postize :: ByteString -> ByteString
                     postize x | B.length x /= 0 && B.head x == '.'= cons '.' x
                               | otherwise                         = x
cGetLine :: Connection -> IO ByteString
cGetLine c = f =<< hGetLine (handle c)
             where f l | B.length l == 0   = aEOL `fmap` cGetLine c
                       | B.last l == '\r'  = return $ B.init l
                       | otherwise         = laEOL `fmap` cGetLine c
                       where aEOL = (hEOLSeq `append`)
                             laEOL = (l `append` hEOLSeq `append`)
cGetText :: Connection -> (ByteString -> IO a) -> IO [a]
cGetText c f = process =<< cGetLine c
             where process l = if B.length l == 1 && B.head l == '.'
                               then return []
                               else liftM2 (:) (f depost) $ cGetText c f
                               where depost = if unpack (B.take 2 l) == ".."
                                              then B.tail l
                                              else l