{-# LANGUAGE PackageImports , DataKinds , NamedFieldPuns , NumDecimals , OverloadedLists , OverloadedStrings , PatternSynonyms , RecordWildCards , ScopedTypeVariables , TupleSections , TypeApplications , TypeInType , TypeOperators , ViewPatterns #-} {-| Module : UcamWebauth.Data Description : Data types used in Ucam-Webauth protocol Maintainer : David Baynard -} module UcamWebauth.Data ( UcamWebauthInfo() , approveUniq , approveUser , approveAttribs , approveLife , approveParams -- $request , ucamWebauthQuery , AuthRequest() , ucamQVer , ucamQUrl , ucamQDesc , ucamQAauth , ucamQIact , ucamQMsg , ucamQParams , ucamQDate , ucamQFail -- $SignedAuthResponse , SignedAuthResponse() , MaybeValidResponse , ValidResponse , ucamAResponse , ucamAToSign , ucamAKid , ucamASig , AuthResponse() , ucamAVer , ucamAStatus , ucamAMsg , ucamAIssue , ucamAId , ucamAUrl , ucamAPrincipal , ucamAPtags , ucamAAuth , ucamASso , ucamALife , ucamAParams -- $typed , getAuthInfo , WLSVersion(..) , displayWLSVersion , AuthType(..) , displayAuthType , Ptag(..) , displayPtag , StatusCode(..) , responseCodes , getStatus , noAuth510 , protoErr520 , paramErr530 , noInteract540 , unAuthAgent560 , declined570 , YesNo(..) , displayYesNo , YesOnly(YesOnly) , displayYesOnly , KeyID() , UcamTime() , zonedUcamTime , ucamTime , TimePeriod() , secondsFromTimePeriod , timePeriodFromSeconds , WAAState() , wSet , aReq , WAASettings() , SetWAA , authAccepted , needReauthentication , syncTimeOut , validKids , recentTime , applicationUrl , wlsUrl , importedKeys , ucamWebauthHeader , Base64UBS() , Base64UBSL() , UcamBase64BS() , UcamBase64BSL() , ASCII() , convertB64Ucam , convertB64UcamL , convertUcamB64 , convertUcamB64L , decodeUcamB64 , decodeUcamB64L , encodeUcamB64 , encodeUcamB64L , decodeASCII' ) where import "base" Control.Applicative import qualified "aeson" Data.Aeson as A (encode) import "aeson" Data.Aeson.Types (ToJSON) import "bytestring" Data.ByteString (ByteString) import "this" Data.ByteString.B64 import qualified "base64-bytestring" Data.ByteString.Base64.URL as B import qualified "base64-bytestring" Data.ByteString.Base64.URL.Lazy as BL import "bytestring" Data.ByteString.Builder import qualified "bytestring" Data.ByteString.Char8 as B import qualified "bytestring" Data.ByteString.Lazy as BSL import qualified "bytestring" Data.ByteString.Lazy.Char8 as BL import qualified "case-insensitive" Data.CaseInsensitive as CI (mk) import "base" Data.Char (isAlphaNum, isAscii) import "containers" Data.Map.Strict (Map) import "base" Data.List.NonEmpty (NonEmpty) import "base" Data.Maybe (catMaybes) import "text" Data.Text (Text) import qualified "text" Data.Text as T import "text" Data.Text.Encoding import "time" Data.Time import "timerep" Data.Time.RFC3339 import "microlens" Lens.Micro import "microlens-mtl" Lens.Micro.Mtl import "http-types" Network.HTTP.Types import "this" UcamWebauth.Data.Internal ------------------------------------------------------------------------------ -- * Lenses ------------------------------------------------------------------------------ -- ** 'UcamWebauthInfo' {-| Unique representation of response, composed of issue and id -} approveUniq :: UcamWebauthInfo a `Lens'` (UTCTime, Text) approveUniq f AuthInfo{..} = (\_approveUniq -> AuthInfo{_approveUniq, ..}) <$> f _approveUniq {-| Identity of authenticated user -} approveUser :: UcamWebauthInfo a `Lens'` Text approveUser f AuthInfo{..} = (\_approveUser -> AuthInfo{_approveUser, ..}) <$> f _approveUser {-| Comma separated attributes of user -} approveAttribs :: UcamWebauthInfo a `Lens'` [Ptag] approveAttribs f AuthInfo{..} = (\_approveAttribs -> AuthInfo{_approveAttribs, ..}) <$> f _approveAttribs {-| Remaining lifetime in seconds of application -} approveLife :: UcamWebauthInfo a `Lens'` Maybe TimePeriod approveLife f AuthInfo{..} = (\_approveLife -> AuthInfo{_approveLife, ..}) <$> f _approveLife {-| A copy of the params from the request -} approveParams :: UcamWebauthInfo a `Lens'` Maybe a approveParams f AuthInfo{..} = (\_approveParams -> AuthInfo{_approveParams, ..}) <$> f _approveParams ------------------------------------------------------------------------------ -- * The request {-| Build a request header to send to the @WLS@, using an 'AuthRequest' -} ucamWebauthQuery :: ToJSON a => SetWAA a -> [Header] ucamWebauthQuery (configWAA -> waa) = catMaybes [ location , ucamHeader ] where location :: Maybe Header location = pure . (hLocation,) . toByteString $ baseUrl waa <> theQuery ucamHeader :: Maybe Header ucamHeader = (, "1") . CI.mk <$> waa ^. wSet . ucamWebauthHeader baseUrl :: WAAState a -> Builder baseUrl = encodeUtf8Builder . view (wSet . wlsUrl) theQuery :: Builder theQuery = renderQueryBuilder True $ strictQs <> textQs <> lazyQs strictQs :: Query strictQs = toQuery @[(Text, Maybe ByteString)] [ ("ver", pure . bsDisplayWLSVersion $ waa ^. aReq . ucamQVer) , ("desc", encodeUtf8 . decodeASCII' <$> waa ^. aReq . ucamQDesc) , ("iact", bsDisplayYesNo <$> waa ^. aReq . ucamQIact) , ("fail", bsDisplayYesOnly <$> waa ^. aReq . ucamQFail) ] textQs :: Query textQs = toQuery @[(Text, Maybe Text)] [ ("url" , pure $ waa ^. aReq . ucamQUrl) , ("date", unUcamTime . ucamTime <$> waa ^. aReq . ucamQDate) , ("aauth", T.intercalate "," . fmap displayAuthType <$> waa ^. aReq . ucamQAauth) , ("msg", waa ^. aReq . ucamQMsg) ] lazyQs :: Query lazyQs = toQuery @[(Text, Maybe BSL.ByteString)] [ ("params", unUcamB64L . encodeUcamB64L . A.encode <$> waa ^. aReq . ucamQParams) ] toByteString = BSL.toStrict . toLazyByteString ------------------------------------------------------------------------------ -- ** 'AuthRequest' {- $request The handshake between the @WLS@ and @WAA@ are represented using the 'AuthRequest' and 'SignedAuthResponse' data types. The 'AuthResponse' type represents the content of a 'SignedAuthResponse'. Constructors and accessors are not exported, and the 'AuthRequest' should be build using the smart constructors provided. -} {-| The version of @WLS.@ 1, 2 or 3. -} ucamQVer :: AuthRequest a `Lens'` WLSVersion ucamQVer f MakeAuthRequest{..} = (\_ucamQVer -> MakeAuthRequest{_ucamQVer, ..}) <$> f _ucamQVer {-| Full http(s) url of resource request for display, and redirection after authentication at the @WLS@ TODO __This is required__ -} ucamQUrl :: AuthRequest a `Lens'` Text ucamQUrl f MakeAuthRequest{..} = (\_ucamQUrl -> MakeAuthRequest{_ucamQUrl, ..}) <$> f _ucamQUrl {-| Description, transmitted as ASCII -} ucamQDesc :: AuthRequest a `Lens'` Maybe ASCII ucamQDesc f MakeAuthRequest{..} = (\_ucamQDesc -> MakeAuthRequest{_ucamQDesc, ..}) <$> f _ucamQDesc {-| Comma delimited sequence of text tokens representing satisfactory authentication methods -} ucamQAauth :: AuthRequest a `Lens'` Maybe [AuthType] ucamQAauth f MakeAuthRequest{..} = (\_ucamQAauth -> MakeAuthRequest{_ucamQAauth, ..}) <$> f _ucamQAauth {-| A token (Yes/No). Yes requires re-authentication. No requires no interaction. -} ucamQIact :: AuthRequest a `Lens'` Maybe YesNo ucamQIact f MakeAuthRequest{..} = (\_ucamQIact -> MakeAuthRequest{_ucamQIact, ..}) <$> f _ucamQIact {-| Why is authentication being requested? -} ucamQMsg :: AuthRequest a `Lens'` Maybe Text ucamQMsg f MakeAuthRequest{..} = (\_ucamQMsg -> MakeAuthRequest{_ucamQMsg, ..}) <$> f _ucamQMsg {-| Data to be returned to the application -} ucamQParams :: AuthRequest a `Lens'` Maybe a ucamQParams f MakeAuthRequest{..} = (\_ucamQParams -> MakeAuthRequest{_ucamQParams, ..}) <$> f _ucamQParams {-| RFC 3339 representation of application’s time -} ucamQDate :: AuthRequest a `Lens'` Maybe UTCTime ucamQDate f MakeAuthRequest{..} = (\_ucamQDate -> MakeAuthRequest{_ucamQDate, ..}) <$> f _ucamQDate {-| Error token. If 'yes', the @WLS@ implements error handling -} ucamQFail :: AuthRequest a `Lens'` Maybe YesOnly ucamQFail f MakeAuthRequest{..} = (\_ucamQFail -> MakeAuthRequest{_ucamQFail, ..}) <$> f _ucamQFail -------------------------------------------------- -- ** 'SignedAuthResponse' -------------------------------------------------- {- $SignedAuthResponse It is helpful to have type synonyms for valid or otherwise 'SignedAuthRepsonse's. -} type MaybeValidResponse a = SignedAuthResponse 'MaybeValid a type ValidResponse a = SignedAuthResponse 'Valid a {-| The bit of the response that is signed -} ucamAResponse :: SignedAuthResponse valid a `Lens'` AuthResponse a ucamAResponse f SignedAuthResponse{..} = (\_ucamAResponse -> SignedAuthResponse{_ucamAResponse, ..}) <$> f _ucamAResponse {-| The raw text of the response, used to verify the signature -} ucamAToSign :: SignedAuthResponse valid a `Lens'` ByteString ucamAToSign f SignedAuthResponse{..} = (\_ucamAToSign -> SignedAuthResponse{_ucamAToSign, ..}) <$> f _ucamAToSign {-| RSA key identifier. Must be a string of 1–8 characters, chosen from digits 0–9, with no leading 0, i.e. [1-9][0-9]{0,7} -} ucamAKid :: SignedAuthResponse valid a `Lens'` Maybe KeyID ucamAKid f SignedAuthResponse{..} = (\_ucamAKid -> SignedAuthResponse{_ucamAKid, ..}) <$> f _ucamAKid {-| Required if status is 200, otherwise Nothing. Public key signature of everything up to kid, using the private key identified by kid, the SHA-1 algorithm and RSASSA-PKCS1-v1_5 (PKCS #1 v2.1 RFC 3447), encoded using the base64 scheme (RFC 1521) but with "-._" replacing "+/=" (equivalent to the RFC 4648 with "._" replacing "_="). -} ucamASig :: SignedAuthResponse valid a `Lens'` Maybe UcamBase64BS ucamASig f SignedAuthResponse{..} = (\_ucamASig -> SignedAuthResponse{_ucamASig, ..}) <$> f _ucamASig -------------------------------------------------- -- ** 'AuthResponse' -------------------------------------------------- {-| The version of @WLS@: 1, 2 or 3 -} ucamAVer :: AuthResponse a `Lens'` WLSVersion ucamAVer f AuthResponse{..} = (\_ucamAVer -> AuthResponse{_ucamAVer, ..}) <$> f _ucamAVer {-| 3 digit status code (200 is success) -} ucamAStatus :: AuthResponse a `Lens'` StatusCode ucamAStatus f AuthResponse{..} = (\_ucamAStatus -> AuthResponse{_ucamAStatus, ..}) <$> f _ucamAStatus {-| The status, for users -} ucamAMsg :: AuthResponse a `Lens'` Maybe Text ucamAMsg f AuthResponse{..} = (\_ucamAMsg -> AuthResponse{_ucamAMsg, ..}) <$> f _ucamAMsg {-| RFC 3339 representation of response’s time -} ucamAIssue :: AuthResponse a `Lens'` UTCTime ucamAIssue f AuthResponse{..} = (\_ucamAIssue -> AuthResponse{_ucamAIssue, ..}) <$> f _ucamAIssue {-| Not unguessable identifier, id + issue are unique -} ucamAId :: AuthResponse a `Lens'` Text ucamAId f AuthResponse{..} = (\_ucamAId -> AuthResponse{_ucamAId, ..}) <$> f _ucamAId {-| Same as request -} ucamAUrl :: AuthResponse a `Lens'` Text ucamAUrl f AuthResponse{..} = (\_ucamAUrl -> AuthResponse{_ucamAUrl, ..}) <$> f _ucamAUrl {-| Identity of authenticated user. Must be present if ucamAStatus is 200, otherwise must be Nothing -} ucamAPrincipal :: AuthResponse a `Lens'` Maybe Text ucamAPrincipal f AuthResponse{..} = (\_ucamAPrincipal -> AuthResponse{_ucamAPrincipal, ..}) <$> f _ucamAPrincipal {-| Comma separated attributes of principal. Optional in version 3, must be Nothing otherwise. -} ucamAPtags :: AuthResponse a `Lens'` [Ptag] ucamAPtags f AuthResponse{..} = (\_ucamAPtags -> AuthResponse{_ucamAPtags, ..}) <$> f _ucamAPtags {-| Authentication type if successful, else Nothing -} ucamAAuth :: AuthResponse a `Lens'` Maybe AuthType ucamAAuth f AuthResponse{..} = (\_ucamAAuth -> AuthResponse{_ucamAAuth, ..}) <$> f _ucamAAuth {-| Comma separated list of previous authentications. Required if ucamAAuth is Nothing. -} ucamASso :: AuthResponse a `Lens'` Maybe (NonEmpty AuthType) ucamASso f AuthResponse{..} = (\_ucamASso -> AuthResponse{_ucamASso, ..}) <$> f _ucamASso {-| Remaining lifetime in seconds of application -} ucamALife :: AuthResponse a `Lens'` Maybe TimePeriod ucamALife f AuthResponse{..} = (\_ucamALife -> AuthResponse{_ucamALife, ..}) <$> f _ucamALife {-| A copy of the params from the request -} ucamAParams :: AuthResponse a `Lens'` Maybe a ucamAParams f AuthResponse{..} = (\_ucamAParams -> AuthResponse{_ucamAParams, ..}) <$> f _ucamAParams {-| Takes a validated 'SignedAuthResponse', and returns the corresponding 'UcamWebauthInfo'. -} getAuthInfo :: Alternative f => SignedAuthResponse 'Valid a -> f (UcamWebauthInfo a) getAuthInfo = extractAuthInfo . _ucamAResponse ------------------------------------------------------------------------------ -- * Typed representations of protocol data {- $typed These types represent data such as the protocol version ('WLSVersion') that is inherently typed but has a string representation in the protocol -} ------------------------------------------------------------------------------ -- *** Time {-| Convert the protocol time representation to a 'UTCTime', based on the 'utc' time zone. -} zonedUcamTime :: UcamTime -> Maybe ZonedTime zonedUcamTime = parseTimeRFC3339 . unUcamTime {-| Convert a 'UTCTime' to the protocol time representation, based on the 'utc' time zone. -} ucamTime :: UTCTime -> UcamTime ucamTime = UcamTime . T.filter isAlphaNum . formatTimeRFC3339 . utcToZonedTime utc ------------------------------------------------------------------------------ -- * 'WAASettings' and lenses wSet :: WAAState a `Lens'` WAASettings wSet f MakeWAAState{..} = (\_wSet -> MakeWAAState{_wSet, ..}) <$> f _wSet aReq :: WAAState a `Lens'` AuthRequest a aReq f MakeWAAState{..} = (\_aReq -> MakeWAAState{_aReq, ..}) <$> f _aReq {-| Accepted authentication types by the protocol. Default @['Pwd']@ -} authAccepted :: WAASettings `Lens'` [AuthType] authAccepted f MakeWAASettings{..} = (\_authAccepted -> MakeWAASettings{_authAccepted, ..}) <$> f _authAccepted {-| 'Just' 'True' means ‘must reauthenticate’, 'Just' 'False' means ‘non-interactive’, 'Nothing' means anything goes. Default 'Nothing' -} needReauthentication :: WAASettings `Lens'` Maybe YesNo needReauthentication f MakeWAASettings{..} = (\_needReauthentication -> MakeWAASettings{_needReauthentication, ..}) <$> f _needReauthentication {-| A timeout for the response validation. Default @40@ (seconds) -} syncTimeOut :: WAASettings `Lens'` NominalDiffTime syncTimeOut f MakeWAASettings{..} = (\_syncTimeOut -> MakeWAASettings{_syncTimeOut, ..}) <$> f _syncTimeOut {-| Valid 'KeyID' values for the protocol. Default @[]@ (/i.e./ no valid keys) -} validKids :: WAASettings `Lens'` [KeyID] validKids f MakeWAASettings{..} = (\_validKids -> MakeWAASettings{_validKids, ..}) <$> f _validKids {-| The last time something interesting happened. With an interesting definition of interesting. Default is the start of 'UTCTime'. TODO Document when this is updated, here. -} recentTime :: WAASettings `Lens'` UTCTime recentTime f MakeWAASettings{..} = (\_recentTime -> MakeWAASettings{_recentTime, ..}) <$> f _recentTime {-| The url to be transmitted to the @WLS@ is the url to which it redirects the user’s browser after the submission, and the url which it displays to the user (in the case of Raven). TODO Default is empty. The implementation __must__ override it. -} applicationUrl :: WAASettings `Lens'` Text applicationUrl f MakeWAASettings{..} = (\_applicationUrl -> MakeWAASettings{_applicationUrl, ..}) <$> f _applicationUrl {-| The url to be transmitted to the @WLS@ is the url to which it redirects the user’s browser after the submission, and the url which it displays to the user (in the case of Raven). TODO Default is empty. The implementation __must__ override it. -} wlsUrl :: WAASettings `Lens'` Text wlsUrl f MakeWAASettings{..} = (\_wlsUrl -> MakeWAASettings{_wlsUrl, ..}) <$> f _wlsUrl {-| Rather than acquiring the keys from a static directory, it is possible to supply the key data during compilation; these are stored in a map, here. Defaults to an empty map. -} importedKeys :: WAASettings `Lens'` Map KeyID ByteString importedKeys f MakeWAASettings{..} = (\_importedKeys -> MakeWAASettings{_importedKeys, ..}) <$> f _importedKeys {-| We may need to pass a custom header to identify the redirect to a javascript client. The header name is contained here (the value is set to '1'). Default is empty, which should be implemented to correspond to no header. -} ucamWebauthHeader :: WAASettings `Lens'` Maybe ByteString ucamWebauthHeader f MakeWAASettings{..} = (\_ucamWebauthHeader -> MakeWAASettings{_ucamWebauthHeader, ..}) <$> f _ucamWebauthHeader ------------------------------------------------------------------------------ -- * Text encoding {-| Convert to the protocol’s version of base64 -} convertB64Ucam :: Base64UBS tag -> UcamBase64BS convertB64Ucam = UcamB64 . B.map camEncodeFilter . unB64U convertB64UcamL :: Base64UBSL tag -> UcamBase64BSL convertB64UcamL = UcamB64L . BL.map camEncodeFilter . unB64UL camEncodeFilter :: Char -> Char camEncodeFilter '_' = '.' camEncodeFilter '=' = '_' camEncodeFilter x = x {-| Convert from the protocol’s version of base64 -} convertUcamB64 :: UcamBase64BS -> Base64UBS tag convertUcamB64 = B64U . B.map camDecodeFilter . unUcamB64 convertUcamB64L :: UcamBase64BSL -> Base64UBSL tag convertUcamB64L = B64UL . BL.map camDecodeFilter . unUcamB64L camDecodeFilter :: Char -> Char camDecodeFilter '.' = '_' camDecodeFilter '_' = '=' camDecodeFilter x = x {-| This uses 'B.decodeLenient' internally. TODO It should not be a problem, if operating on validated input, but might be worth testing (low priority). -} decodeUcamB64 :: UcamBase64BS -> ByteString decodeUcamB64 = B.decodeLenient . unB64U . convertUcamB64 decodeUcamB64L :: UcamBase64BSL -> BSL.ByteString decodeUcamB64L = BL.decodeLenient . unB64UL . convertUcamB64L {-| Unlike decoding, this is fully pure. -} encodeUcamB64 :: ByteString -> UcamBase64BS encodeUcamB64 = convertB64Ucam . B64U . B.encode encodeUcamB64L :: BSL.ByteString -> UcamBase64BSL encodeUcamB64L = convertB64UcamL . B64UL . BL.encode {-| Extract ascii text. TODO Use Haskell’s utf7 functions -} decodeASCII' :: ASCII -> Text decodeASCII' = T.filter isAscii . unASCII