{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- |
-- HTTP POST Binding
--
-- <https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf saml-bindings-2.0-os> §3.5
module SAML2.Bindings.HTTPPOST
  ( encodeValue
  , encodeForm
  , decodeValue
  , decodeForm
  ) where

import Control.Lens ((^.), (.~))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy as BSL
import Data.Maybe (maybeToList)
import Data.Proxy (Proxy(..))

import SAML2.XML
import SAML2.Lens
import qualified SAML2.Core.Protocols as SAMLP
import SAML2.Core.Signature
import SAML2.Bindings.General
import SAML2.Bindings.Internal

encodeValue :: SAMLP.SAMLProtocol a => a -> BS.ByteString
encodeValue :: a -> ByteString
encodeValue = ByteString -> ByteString
Base64.encode (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. XmlPickler a => a -> ByteString
samlToXML

encodeForm :: SAMLP.SAMLProtocol a => a -> [(BS.ByteString, BS.ByteString)]
encodeForm :: a -> [(ByteString, ByteString)]
encodeForm a
p =
  (Bool -> ByteString
forall a. IsString a => Bool -> a
protocolParameter (a -> Bool
forall a. SAMLProtocol a => a -> Bool
SAMLP.isSAMLResponse a
p), a -> ByteString
forall a. SAMLProtocol a => a -> ByteString
encodeValue a
p)
  (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: Maybe (ByteString, ByteString) -> [(ByteString, ByteString)]
forall a. Maybe a -> [a]
maybeToList ((ByteString
forall a. IsString a => a
relayStateParameter, ) (ByteString -> (ByteString, ByteString))
-> Maybe ByteString -> Maybe (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolType -> Maybe ByteString
SAMLP.relayState (a
p a -> Getting ProtocolType a ProtocolType -> ProtocolType
forall s a. s -> Getting a s a -> a
^. Getting ProtocolType a ProtocolType
forall a. SAMLProtocol a => Lens' a ProtocolType
SAMLP.samlProtocol'))

decodeValue :: SAMLP.SAMLProtocol a => Bool -> BS.ByteString -> IO a
decodeValue :: Bool -> ByteString -> IO a
decodeValue Bool
verf ByteString
v = do
  if Bool
verf
    then ByteString -> IO a
forall a. SAMLProtocol a => ByteString -> IO a
verifySAMLProtocol ByteString
b
    else (String -> IO a) -> (a -> IO a) -> Either String a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO a) -> Either String a -> IO a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String a
forall a. XmlPickler a => ByteString -> Either String a
xmlToSAML ByteString
b
  where b :: ByteString
b = ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base64.decodeLenient ByteString
v

decodeForm :: forall a . (SAMLP.SAMLProtocol a) => Bool -> (BS.ByteString -> Maybe BS.ByteString) -> IO a
decodeForm :: Bool -> (ByteString -> Maybe ByteString) -> IO a
decodeForm Bool
verf ByteString -> Maybe ByteString
f = do
  a
p <- Bool -> ByteString -> IO a
forall a. SAMLProtocol a => Bool -> ByteString -> IO a
decodeValue Bool
verf (ByteString -> IO a) -> IO ByteString -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString
-> (ByteString -> IO ByteString)
-> Maybe ByteString
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"SAML parameter missing") ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Proxy a -> (ByteString -> Maybe ByteString) -> Maybe ByteString
forall m p a.
(SAMLProtocol m, IsString p) =>
Proxy m -> (p -> Maybe a) -> Maybe a
lookupProtocolParameter (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) ByteString -> Maybe ByteString
f)
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ (ProtocolType -> Identity ProtocolType) -> a -> Identity a
forall a. SAMLProtocol a => Lens' a ProtocolType
SAMLP.samlProtocol' ((ProtocolType -> Identity ProtocolType) -> a -> Identity a)
-> ((Maybe ByteString -> Identity (Maybe ByteString))
    -> ProtocolType -> Identity ProtocolType)
-> (Maybe ByteString -> Identity (Maybe ByteString))
-> a
-> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. $(fieldLens 'SAMLP.relayState) ((Maybe ByteString -> Identity (Maybe ByteString))
 -> a -> Identity a)
-> Maybe ByteString -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (ByteString -> Maybe ByteString
f ByteString
forall a. IsString a => a
relayStateParameter) (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
p