{-# LANGUAGE FlexibleInstances #-}
module Network.Shelob.Client where

import           Control.Monad.IO.Class (MonadIO(..))
import qualified Control.Exception as Ex
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.Socket as Sock
import qualified System.IO as H

import           Network.Shelob
import           Network.Shelob.Connection
import           Network.Shelob.Types


newtype ConnM a = ConnM { runConnM :: Connection -> IO a }

instance Functor ConnM where
  fmap f (ConnM g) = ConnM (\ c -> fmap f (g c))

instance Applicative ConnM where
  pure x = ConnM (\ _ -> return x)
  ConnM f <*> ConnM x = ConnM $ \ c -> do
    f' <- f c
    x' <- x c
    return (f' x')

instance Monad ConnM where
  ConnM x >>= f = ConnM $ \ c -> do
    x' <- x c
    runConnM (f x') c

instance MonadIO ConnM where
  liftIO m = ConnM (\ _ -> m)

-- * HTTPPayload

-- | Types that implement 'HTTPPayload' can be transparently used as
-- the body of an HTTP request.
class HTTPPayload t where
  toPayload :: t -> BS.ByteString

instance HTTPPayload BS.ByteString where
  toPayload = id

instance HTTPPayload T.Text where
  toPayload = T.encodeUtf8

-- | The 'JSONPayload' type is used so that we can interpret the
-- payload of a response
newtype JSONPayload t = JSONPayload { fromJSONPayload :: t }

instance Aeson.FromJSON t => Aeson.FromJSON (JSONPayload t) where
  parseJSON x = fmap JSONPayload (Aeson.parseJSON x)

-- * HTTPResult
class HTTPResult t where
  fromResponse :: Either HTTPError Response -> t

instance HTTPResult r => HTTPResult (Either HTTPError r) where
  fromResponse (Left err) = Left err
  fromResponse (Right v)  = Right (fromResponse (Right v))

instance HTTPResult r => HTTPResult (Maybe r) where
  fromResponse (Left _)  = Nothing
  fromResponse (Right v) = Just (fromResponse (Right v))

onSuccess :: (Response -> a) -> Either HTTPError Response -> a
onSuccess _ (Left err) = Ex.throw err
onSuccess f (Right v)  = f v

instance HTTPResult Response where
  fromResponse = onSuccess id

instance HTTPResult BS.ByteString where
  fromResponse = onSuccess (go . responseBody)
    where go Nothing  = Ex.throw HTTPError
          go (Just x) = x

instance Aeson.FromJSON t => HTTPResult (JSONPayload t) where
  fromResponse = onSuccess (go . responseBody)
    where go Nothing  = Ex.throw HTTPError
          go (Just x)
            | Just rs <- Aeson.decodeStrict x = JSONPayload rs
            | otherwise = Ex.throw HTTPError

withConn :: Connection -> ConnM a -> IO a
withConn conn m = do
  rs <- runConnM m conn
  connClose conn
  return rs

doRequest :: HTTPResult r => Request -> ConnM r
doRequest req = ConnM (\ c -> fromResponse `fmap` makeRequest c req)

head :: HTTPResult r => BS.ByteString -> [Header] -> ConnM r
head p hs = doRequest (Request MHead p (hs' ++ hs) "")
  where hs' = [ Header "Content-Length" "0"
              , userAgent
              ]

get :: HTTPResult r => BS.ByteString -> [Header] -> ConnM r
get p hs = doRequest (Request MGet p (hs' ++ hs) "")
  where hs' = [ Header "Content-Length" "0"
              , userAgent
              ]

post :: HTTPResult r => BS.ByteString -> [Header] -> BS.ByteString -> ConnM r
post p hs body = doRequest (Request MPost p (hs' ++ hs) body)
  where hs' = [ Header "Content-Length" (BS8.pack (show (BS.length body)))
              , userAgent
              ]

httpConnection :: String -> IO Connection
httpConnection host = do
  addrInfo <- Sock.getAddrInfo Nothing (Just host) (Just "http")
  case addrInfo of
    [] -> error ("unable to look up " ++ host)
    info:_ -> do
      s <- Sock.socket (Sock.addrFamily info)
                       (Sock.addrSocketType info)
                       (Sock.addrProtocol info)
      Sock.connect s (Sock.addrAddress info)
      h <- Sock.socketToHandle s H.ReadWriteMode
      return $ handleToConnection h