servant-auth-client-browser code for implementing servant-auth-client using cookies in ghcjs

Browser.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE AutoDeriveTypeable         #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# OPTIONS_GHC -fno-warn-orphans       #-}
#if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Servant.Auth.Client.Browser
  ( XSRFToken(..)
  , XsrfCookieName
  , XsrfHeaderName

  , getXSRFToken
  , getXSRFTokenDefault

  , deleteXSRFCookie
  , deleteXSRFCookieDefault

  , withAuthToken
  , withAuthTokenDefault
  ) where

import qualified Data.ByteString    as BS
import qualified Data.ByteString.Char8 as BC8
import qualified Data.CaseInsensitive as CI
import           Data.Monoid ((<>))
import           Data.Proxy         (Proxy (..))
import qualified Data.Sequence      as Seq
import           GHCJS.DOM          (currentDocumentUnchecked)
import           GHCJS.DOM.Document (getCookie, setCookie)
import           GHC.Exts           (Constraint)
import           GHC.Generics       (Generic)
import           Servant.API        ((:>))
import           Servant.Auth
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Servant.Client.Core
import qualified Web.Cookie as Cookie

-- | A compact XSRF Token.
data XSRFToken
   = XSRFToken
     { _xsrfTokenHeaderName :: !XsrfHeaderName
     , _xsrfTokenValue      :: !BS.ByteString
     }
  deriving (Eq, Show, Read, Generic)

type XsrfCookieName = T.Text
type XsrfHeaderName = BS.ByteString

defaultXsrfCookieName :: XsrfCookieName
defaultXsrfCookieName = "XSRF-TOKEN"

defaultXsrfHeaderName :: XsrfHeaderName
defaultXsrfHeaderName = "X-XSRF-TOKEN"

getXSRFToken :: XsrfCookieName -> XsrfHeaderName -> IO (Maybe XSRFToken)
getXSRFToken xsrfCookieName xsrfHeaderName = do
    d <- currentDocumentUnchecked
    (cookieString :: String) <- getCookie d
    pure $
      fmap (XSRFToken xsrfHeaderName . TE.encodeUtf8) $
      lookup xsrfCookieName $
      Cookie.parseCookiesText $
      BC8.pack cookieString

getXSRFTokenDefault :: IO (Maybe XSRFToken)
getXSRFTokenDefault = getXSRFToken defaultXsrfCookieName defaultXsrfHeaderName

deleteXSRFCookie :: XsrfCookieName -> IO ()
deleteXSRFCookie xsrfCookieName = do
    d <- currentDocumentUnchecked
    setCookie d $ xsrfCookieName <> "=; expires=Thu, 01 Jan 1970 00:00:00 GMT"

deleteXSRFCookieDefault :: IO ()
deleteXSRFCookieDefault = deleteXSRFCookie defaultXsrfCookieName

withAuthToken
    :: XsrfCookieName
    -> XsrfHeaderName
    -> a
    -> (XSRFToken -> IO a)
    -> IO a
withAuthToken xsrfCookieName xsrfHeaderName def f = do
    mbToken <- getXSRFToken xsrfCookieName xsrfHeaderName
    case mbToken of
      Nothing -> pure def
      Just token -> f token

withAuthTokenDefault :: a -> (XSRFToken -> IO a) -> IO a
withAuthTokenDefault = withAuthToken defaultXsrfCookieName defaultXsrfHeaderName

    -- HasCookie auths is nominally a redundant constraint, but ensures we're not
    -- trying to send a token to an API that doesn't accept them.
instance (HasCookie auths, HasClient m api) => HasClient m (Auth auths a :> api) where

  type Client m (Auth auths a :> api) = XSRFToken -> Client m api

  clientWithRoute pm _ req (XSRFToken header token) =
      clientWithRoute pm (Proxy :: Proxy api) $
        req { requestHeaders = (CI.mk header, token) Seq.<| requestHeaders req  }

type family HasCookie xs :: Constraint where
    HasCookie (Cookie ': xs) = ()
    HasCookie (x ': xs)   = HasCookie xs
    HasCookie '[]         = CookieAuthNotEnabled

class CookieAuthNotEnabled