module Network.NNTP.RFC977
(
Connection,
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)
data Connection = Connection {
handle :: System.IO.Handle
}
joinToSocket :: Socket
-> IO (Connection, Bool)
joinToSocket = flip socketToHandle ReadWriteMode >=> joinToHandle
joinToHandle :: System.IO.Handle
-> IO (Connection, Bool)
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"
connectToHost :: String
-> Maybe Word16
-> IO (Connection, Bool)
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
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