{-# LANGUAGE RecordWildCards #-}

module Zero.Hawk
  (
    HeaderOptions(..)
  , Credentials(..)

  , formHawkHeader
  , headerField
  , headerOptions
  , rawHeader
  , rawHeaderField
  ) where

import           Control.Monad.IO.Class (liftIO)
import           GHC.Generics (Generic)
import           GHCJS.Types (JSVal, IsJSVal)
import           GHCJS.Marshal (FromJSVal(..), ToJSVal(..))
import           Data.Aeson
import           Data.Typeable
import qualified Data.Text as T
import           Data.Text (Text)
import           Data.JSString (JSString)
import qualified Data.JSString as JSS
import           Reflex.Dom.Core
import           Zero.GHCJS
import           Zero.Token

------------------------------------------------------------------------------
-- Types
------------------------------------------------------------------------------

newtype Header = Header JSVal
  deriving (Typeable)

instance IsJSVal Header

data HeaderOptions = HeaderOptions
  { ho_credentials :: Credentials
  , ho_contentType :: Text
  , ho_payload     :: Maybe Text
  , ho_ext         :: Text
  } deriving (Show, Generic)

instance ToJSON HeaderOptions where
  toJSON (HeaderOptions credentials contentType (Just payload) ext) =
    object [
      "credentials" .= credentials
    , "payload" .= payload
    , "contentType" .= contentType
    , "ext" .= ext
    ]

  toJSON (HeaderOptions credentials contentType Nothing ext) =
    object [
      "credentials" .= credentials
    , "contentType" .= contentType
    , "ext" .= ext
    ]

instance FromJSON HeaderOptions where
  parseJSON = withObject "HeaderOptions" $ \v -> HeaderOptions
    <$> v .: "credentials"
    <*> v .: "contentType"
    <*> v .:? "payload"
    <*> v .: "ext"

data Credentials = Credentials
  { c_id :: Text
  , c_key :: Text
  , c_algorithm :: Text
  } deriving (Show, Generic)

instance ToJSON Credentials where
  toJSON (Credentials id key algorithm) =
    object [
      "id" .= T.toUpper id
    , "key" .= T.toUpper key
    , "algorithm" .= algorithm
    ]

instance FromJSON Credentials where
  parseJSON = withObject "Credentials" $ \v -> Credentials
    <$> v .: "id"
    <*> v .: "key"
    <*> v .: "algorithm"

------------------------------------------------------------------------------

-- | Creates a HAWK request header.
formHawkHeader :: MonadWidget t m
  => Text -> Text -> Text -> Event t (Token, Maybe Text) -> m (Event t (Either Text (Text, Text, JSVal)))
formHawkHeader path method contentType e =
  performEvent $ fmap (liftIO . headerOptions path method contentType) e

------------------------------------------------------------------------------

-- | Creates the basic HAWK header options.
headerOptions :: Text -> Text -> Text -> (Token, Maybe Text) -> IO (Either Text (Text, Text, JSVal))
headerOptions path method contentType (Token{..}, payload) = do
  let opts = HeaderOptions (Credentials t_id t_key "sha256") contentType payload "zero"
  optsv <- toJSVal_aeson opts
  return $ Right (path, method, optsv)

headerField :: Header -> Text
headerField =
  T.pack . JSS.unpack . js_field

-- | Returns the HAWK header field.
rawHeaderField :: (Text, Text, JSVal) -> Text
rawHeaderField (uri, method, opts) =
  headerField (js_header (JSS.pack $ T.unpack uri) (JSS.pack $ T.unpack method) opts)

-- | Returns the HAWK header as JSON.
rawHeader :: (Text, Text, JSVal) -> Text
rawHeader (uri, method, opts) =
  T.pack $ JSS.unpack $ js_stringify $ js_header (JSS.pack $ T.unpack uri) (JSS.pack $ T.unpack method) opts

------------------------------------------------------------------------------
-- FFI
------------------------------------------------------------------------------

foreign import javascript unsafe "JSON.stringify($1)"
  js_stringify :: Header -> JSString

foreign import javascript unsafe "hawk.client.header($1,$2,$3)"
  js_header :: JSString -> JSString -> JSVal -> Header

foreign import javascript unsafe "($1).field"
  js_field :: Header -> JSString
