module Servant.Auth.Server.Internal.AddSetCookie where
import Blaze.ByteString.Builder (toByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS64
import Data.ByteString.Conversion (ToByteString (..))
import Data.Monoid
import Data.String (IsString)
import qualified Data.Text.Encoding as T
import GHC.Generics (Generic)
import Servant
import System.Entropy (getEntropy)
import Web.Cookie
type family AddSetCookieApi a where
AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
AddSetCookieApi (Verb method stat ctyps (Headers ls a))
= Verb method stat ctyps (Headers ((Header "Set-Cookie" BSS) ': ls) a)
AddSetCookieApi (Verb method stat ctyps a)
= Verb method stat ctyps (Headers '[Header "Set-Cookie" BSS] a)
class AddSetCookie orig new where
addSetCookie :: [SetCookie] -> orig -> new
instance AddSetCookie oldb newb
=> AddSetCookie (a -> oldb) (a -> newb) where
addSetCookie cookie oldfn = \val -> addSetCookie cookie $ oldfn val
instance
( Functor m
, AddHeader "Set-Cookie" BSS old new
) => AddSetCookie (m old) (m new) where
addSetCookie cookie val
= addHeader (BSS $ foldr1 go $ toByteString . renderSetCookie <$> cookie) <$> val
where
go new old = old <> "\r\nSet-Cookie: " <> new
instance
(AddSetCookie a a', AddSetCookie b b')
=> AddSetCookie (a :<|> b) (a' :<|> b') where
addSetCookie cookie (a :<|> b) = addSetCookie cookie a :<|> addSetCookie cookie b
newtype BSS = BSS { getBSS :: BS.ByteString }
deriving (Eq, Show, Read, Generic, IsString, Monoid)
instance ToHttpApiData BSS where
toHeader = getBSS
toUrlPiece = T.decodeUtf8 . getBSS
instance ToByteString BSS where
builder (BSS x) = builder x
csrfCookie :: IO BS.ByteString
csrfCookie = BS64.encode <$> getEntropy 32