{-# LANGUAGE OverloadedStrings #-}
module Pirandello.Kruger ( Address (..), Manager, Host, Port
                         , newManager, krugerLookup, krugerPublish )
                         where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import Control.Monad.Morph (hoist)
import Control.Monad.Trans.Except (ExceptT (ExceptT))
import Control.Monad.Trans.State.Strict (evalStateT)
import Data.Aeson (FromJSON (parseJSON), Value (Object), (.=), (.:), encode, object)
import Data.Text.Encoding (encodeUtf8)
import Pipes.Aeson (decode)
import qualified Pipes.HTTP as H
import Pirandello.Config (Host, Port)
import Pirandello.Events (RemoteId)
import UnexceptionalIO (UIO, fromIO')
import Web.Cookie (def)

data Address = Address Host Port deriving (Show)

data Manager = Manager { http ∷ H.Manager
                       , req  ∷ H.Request }

instance FromJSON Address where
    parseJSON (Object v) = Address <$> v .: "host" <*> v .: "port"
    parseJSON _          = mzero

mkReq ∷ Host → H.Request
mkReq host = def { H.secure = True
                 , H.host = encodeUtf8 host
                 , H.path = "/"
                 , H.port = 443
                 , H.method = "POST" }

-- NB http-client package promises to only throw HttpException
-- https://www.stackage.org/haddock/nightly-2015-03-27/http-client-0.4.9/Network-HTTP-Client.html

newManager ∷ Host → ExceptT H.HttpException UIO Manager
newManager host = ExceptT $ fromIO' $ do
    m ← H.newManager H.tlsManagerSettings
    return Manager { http = m, req = mkReq host }

krugerLookup ∷ Manager → RemoteId → ExceptT H.HttpException UIO (Maybe Address)
krugerLookup man remoteId =
    ExceptT $ fromIO' $ H.withHTTP req' (http man) $ \httpResp → do
        resp ← evalStateT decode (H.responseBody httpResp)
        case resp of
            (Just (Right addr)) → return $ Just addr
            _                   → return Nothing
    where
        req' = (req man) { H.requestBody = H.RequestBodyLBS $ encode body }
        body = object [ "op" .= ("get" ∷ String), "name" .= remoteId ]

krugerPublish ∷ Manager → RemoteId → Address → ExceptT () (ExceptT H.HttpException UIO) ()
krugerPublish man remoteId (Address host port) =
    hoist (ExceptT . fromIO') . ExceptT $ H.withHTTP req' (http man) $ \httpResp → do
        resp ← evalStateT decode (H.responseBody httpResp)
        case resp of
            (Just (Right (Object _))) → return $ Right ()
            _                         → return $ Left  ()
    where
        req' = (req man) { H.requestBody = H.RequestBodyLBS $ encode body }
        body = object [ "op"   .= ("publish" ∷ String)
                      , "name" .= remoteId
                      , "host" .= host
                      , "port" .= port ]
