diff --git a/Changelog.md b/Changelog.md
new file mode 100644
--- /dev/null
+++ b/Changelog.md
@@ -0,0 +1,14 @@
+# Changelog
+
+This changelog is shared among all the packages within the same project.
+
+## 0.1.0.0 - 2018-12-09
+
+Initial versions of `ucam-webauth` and `ucam-webauth-types`.
+
+---
+
+All notable changes to this project will be documented in this file.
+
+The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
+and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/).
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,203 @@
+
+ Apache License
+ Version 2.0, January 2004
+ http://www.apache.org/licenses/
+
+ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
+
+ 1. Definitions.
+
+ "License" shall mean the terms and conditions for use, reproduction,
+ and distribution as defined by Sections 1 through 9 of this document.
+
+ "Licensor" shall mean the copyright owner or entity authorized by
+ the copyright owner that is granting the License.
+
+ "Legal Entity" shall mean the union of the acting entity and all
+ other entities that control, are controlled by, or are under common
+ control with that entity. For the purposes of this definition,
+ "control" means (i) the power, direct or indirect, to cause the
+ direction or management of such entity, whether by contract or
+ otherwise, or (ii) ownership of fifty percent (50%) or more of the
+ outstanding shares, or (iii) beneficial ownership of such entity.
+
+ "You" (or "Your") shall mean an individual or Legal Entity
+ exercising permissions granted by this License.
+
+ "Source" form shall mean the preferred form for making modifications,
+ including but not limited to software source code, documentation
+ source, and configuration files.
+
+ "Object" form shall mean any form resulting from mechanical
+ transformation or translation of a Source form, including but
+ not limited to compiled object code, generated documentation,
+ and conversions to other media types.
+
+ "Work" shall mean the work of authorship, whether in Source or
+ Object form, made available under the License, as indicated by a
+ copyright notice that is included in or attached to the work
+ (an example is provided in the Appendix below).
+
+ "Derivative Works" shall mean any work, whether in Source or Object
+ form, that is based on (or derived from) the Work and for which the
+ editorial revisions, annotations, elaborations, or other modifications
+ represent, as a whole, an original work of authorship. For the purposes
+ of this License, Derivative Works shall not include works that remain
+ separable from, or merely link (or bind by name) to the interfaces of,
+ the Work and Derivative Works thereof.
+
+ "Contribution" shall mean any work of authorship, including
+ the original version of the Work and any modifications or additions
+ to that Work or Derivative Works thereof, that is intentionally
+ submitted to Licensor for inclusion in the Work by the copyright owner
+ or by an individual or Legal Entity authorized to submit on behalf of
+ the copyright owner. For the purposes of this definition, "submitted"
+ means any form of electronic, verbal, or written communication sent
+ to the Licensor or its representatives, including but not limited to
+ communication on electronic mailing lists, source code control systems,
+ and issue tracking systems that are managed by, or on behalf of, the
+ Licensor for the purpose of discussing and improving the Work, but
+ excluding communication that is conspicuously marked or otherwise
+ designated in writing by the copyright owner as "Not a Contribution."
+
+ "Contributor" shall mean Licensor and any individual or Legal Entity
+ on behalf of whom a Contribution has been received by Licensor and
+ subsequently incorporated within the Work.
+
+ 2. Grant of Copyright License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ copyright license to reproduce, prepare Derivative Works of,
+ publicly display, publicly perform, sublicense, and distribute the
+ Work and such Derivative Works in Source or Object form.
+
+ 3. Grant of Patent License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ (except as stated in this section) patent license to make, have made,
+ use, offer to sell, sell, import, and otherwise transfer the Work,
+ where such license applies only to those patent claims licensable
+ by such Contributor that are necessarily infringed by their
+ Contribution(s) alone or by combination of their Contribution(s)
+ with the Work to which such Contribution(s) was submitted. If You
+ institute patent litigation against any entity (including a
+ cross-claim or counterclaim in a lawsuit) alleging that the Work
+ or a Contribution incorporated within the Work constitutes direct
+ or contributory patent infringement, then any patent licenses
+ granted to You under this License for that Work shall terminate
+ as of the date such litigation is filed.
+
+ 4. Redistribution. You may reproduce and distribute copies of the
+ Work or Derivative Works thereof in any medium, with or without
+ modifications, and in Source or Object form, provided that You
+ meet the following conditions:
+
+ (a) You must give any other recipients of the Work or
+ Derivative Works a copy of this License; and
+
+ (b) You must cause any modified files to carry prominent notices
+ stating that You changed the files; and
+
+ (c) You must retain, in the Source form of any Derivative Works
+ that You distribute, all copyright, patent, trademark, and
+ attribution notices from the Source form of the Work,
+ excluding those notices that do not pertain to any part of
+ the Derivative Works; and
+
+ (d) If the Work includes a "NOTICE" text file as part of its
+ distribution, then any Derivative Works that You distribute must
+ include a readable copy of the attribution notices contained
+ within such NOTICE file, excluding those notices that do not
+ pertain to any part of the Derivative Works, in at least one
+ of the following places: within a NOTICE text file distributed
+ as part of the Derivative Works; within the Source form or
+ documentation, if provided along with the Derivative Works; or,
+ within a display generated by the Derivative Works, if and
+ wherever such third-party notices normally appear. The contents
+ of the NOTICE file are for informational purposes only and
+ do not modify the License. You may add Your own attribution
+ notices within Derivative Works that You distribute, alongside
+ or as an addendum to the NOTICE text from the Work, provided
+ that such additional attribution notices cannot be construed
+ as modifying the License.
+
+ You may add Your own copyright statement to Your modifications and
+ may provide additional or different license terms and conditions
+ for use, reproduction, or distribution of Your modifications, or
+ for any such Derivative Works as a whole, provided Your use,
+ reproduction, and distribution of the Work otherwise complies with
+ the conditions stated in this License.
+
+ 5. Submission of Contributions. Unless You explicitly state otherwise,
+ any Contribution intentionally submitted for inclusion in the Work
+ by You to the Licensor shall be under the terms and conditions of
+ this License, without any additional terms or conditions.
+ Notwithstanding the above, nothing herein shall supersede or modify
+ the terms of any separate license agreement you may have executed
+ with Licensor regarding such Contributions.
+
+ 6. Trademarks. This License does not grant permission to use the trade
+ names, trademarks, service marks, or product names of the Licensor,
+ except as required for reasonable and customary use in describing the
+ origin of the Work and reproducing the content of the NOTICE file.
+
+ 7. Disclaimer of Warranty. Unless required by applicable law or
+ agreed to in writing, Licensor provides the Work (and each
+ Contributor provides its Contributions) on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+ implied, including, without limitation, any warranties or conditions
+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+ PARTICULAR PURPOSE. You are solely responsible for determining the
+ appropriateness of using or redistributing the Work and assume any
+ risks associated with Your exercise of permissions under this License.
+
+ 8. Limitation of Liability. In no event and under no legal theory,
+ whether in tort (including negligence), contract, or otherwise,
+ unless required by applicable law (such as deliberate and grossly
+ negligent acts) or agreed to in writing, shall any Contributor be
+ liable to You for damages, including any direct, indirect, special,
+ incidental, or consequential damages of any character arising as a
+ result of this License or out of the use or inability to use the
+ Work (including but not limited to damages for loss of goodwill,
+ work stoppage, computer failure or malfunction, or any and all
+ other commercial damages or losses), even if such Contributor
+ has been advised of the possibility of such damages.
+
+ 9. Accepting Warranty or Additional Liability. While redistributing
+ the Work or Derivative Works thereof, You may choose to offer,
+ and charge a fee for, acceptance of support, warranty, indemnity,
+ or other liability obligations and/or rights consistent with this
+ License. However, in accepting such obligations, You may act only
+ on Your own behalf and on Your sole responsibility, not on behalf
+ of any other Contributor, and only if You agree to indemnify,
+ defend, and hold each Contributor harmless for any liability
+ incurred by, or claims asserted against, such Contributor by reason
+ of your accepting any such warranty or additional liability.
+
+ END OF TERMS AND CONDITIONS
+
+ APPENDIX: How to apply the Apache License to your work.
+
+ To apply the Apache License to your work, attach the following
+ boilerplate notice, with the fields enclosed by brackets "{}"
+ replaced with your own identifying information. (Don't include
+ the brackets!) The text should be enclosed in the appropriate
+ comment syntax for the file format. We also recommend that a
+ file or class name and description of purpose be included on the
+ same "printed page" as the copyright notice for easier
+ identification within third-party archives.
+
+ Copyright {yyyy} {name of copyright owner}
+
+ Licensed under the Apache License, Version 2.0 (the "License");
+ you may not use this file except in compliance with the License.
+ You may obtain a copy of the License at
+
+ http://www.apache.org/licenses/LICENSE-2.0
+
+ Unless required by applicable law or agreed to in writing, software
+ distributed under the License is distributed on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ See the License for the specific language governing permissions and
+ limitations under the License.
+
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,56 @@
+---
+title: Ucam Webauth
+author: David Baynard
+date: 09 Dec 2018
+...
+
+[](https://travis-ci.com/dbaynard/UcamWebauth)
+
+#
+
+The University of Cambridge _Raven_ service uses the _Ucam Webauth_ protocol.
+
+This repository contains a number of Haskell libraries to interact with this system.
+
+# ucam-webauth
+
+[](https://hackage.haskell.org/package/ucam-webauth)
+[](http://stackage.org/lts-13/package/ucam-webauth)
+[](http://stackage.org/nightly/package/ucam-webauth)
+
+This implements the client authentication protocol; specifically, the validation.
+
+# ucam-webauth-types
+
+[](https://hackage.haskell.org/package/ucam-webauth-types)
+[](http://stackage.org/lts-13/package/ucam-webauth-types)
+[](http://stackage.org/nightly/package/ucam-webauth-types)
+
+This implements data types for the client authentication protocol.
+
+There is an internal package which is *not* recommended for use.
+Its only purpose is to split the core functionality among packages for minimal ghcjs dependencies.
+
+# raven-wai
+
+[](https://hackage.haskell.org/package/raven-wai)
+[](http://stackage.org/lts-13/package/raven-wai)
+[](http://stackage.org/nightly/package/raven-wai)
+
+This adds [wai](//hackage.haskell.org/package/wai) middleware enabling authentication using _Raven_.
+
+# servant-raven
+
+[](https://hackage.haskell.org/package/servant-raven)
+[](http://stackage.org/lts-13/package/servant-raven)
+[](http://stackage.org/nightly/package/servant-raven)
+
+API combinators for [servant](//hackage.haskell.org/package/servant), using [servant-auth](//hackage.haskell.org/package/servant-auth).
+
+# servant-raven-server
+
+[](https://hackage.haskell.org/package/servant-raven-server)
+[](http://stackage.org/lts-13/package/servant-raven-server)
+[](http://stackage.org/nightly/package/servant-raven-server)
+
+The handlers for [servant](//hackage.haskell.org/package/servant).
diff --git a/src/Data/ByteString/B64.hs b/src/Data/ByteString/B64.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/B64.hs
@@ -0,0 +1,91 @@
+{-|
+Module : Data.ByteString.B64
+Description : Base 64 ByteStrings (newtypes)
+Maintainer : David Baynard
+ -}
+
+{-# LANGUAGE
+ PackageImports
+ , DataKinds
+ , DeriveDataTypeable
+ , DeriveGeneric
+ , DerivingStrategies
+ , GeneralizedNewtypeDeriving
+ , OverloadedStrings
+ , TypeInType
+ #-}
+
+module Data.ByteString.B64
+ ( Base64UBS(..)
+ , Base64UBSL(..)
+ , UcamBase64BS(..)
+ , UcamBase64BSL(..)
+ , ASCII(..)
+ ) where
+
+import "deepseq" Control.DeepSeq (NFData)
+import "aeson" Data.Aeson.Types
+import "bytestring" Data.ByteString (ByteString)
+import qualified "bytestring" Data.ByteString.Lazy as BSL
+import "base" Data.Data
+import "base" Data.String
+import "text" Data.Text (Text)
+import "text" Data.Text.Encoding
+import qualified "text" Data.Text.Lazy.Encoding as TL
+import "base" GHC.Generics
+
+------------------------------------------------------------------------------
+-- * Text encoding
+
+{-|
+ Ensure Base 64 URL text is not confused with other 'ByteString's
+-}
+newtype Base64UBS (tag :: k) = B64U { unB64U :: ByteString }
+ deriving stock (Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)
+
+instance FromJSON (Base64UBS tag) where
+ parseJSON = withObject "Base 64 URL ByteString" $ \v -> B64U . encodeUtf8
+ <$> v .: "Base 64U ByteString"
+
+instance ToJSON (Base64UBS tag) where
+ toJSON = toJSON . decodeUtf8 . unB64U
+ toEncoding = toEncoding . decodeUtf8 . unB64U
+
+newtype Base64UBSL (tag :: k) = B64UL { unB64UL :: BSL.ByteString }
+ deriving stock (Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)
+
+instance FromJSON (Base64UBSL tag) where
+ parseJSON = withObject "Base 64 URL ByteString" $ \v -> B64UL . TL.encodeUtf8
+ <$> v .: "Base 64U ByteString"
+
+instance ToJSON (Base64UBSL tag) where
+ toJSON = toJSON . TL.decodeUtf8 . unB64UL
+ toEncoding = toEncoding . TL.decodeUtf8 . unB64UL
+
+{-|
+ Ensure Base 64 URL text modified to fit the Ucam-Webauth protocol is not confused with other 'ByteString's
+-}
+newtype UcamBase64BS = UcamB64 { unUcamB64 :: ByteString }
+ deriving stock (Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)
+
+instance FromJSON UcamBase64BS where
+ parseJSON = withObject "Ucam Base 64 URL ByteString" $ \v -> UcamB64 . encodeUtf8
+ <$> v .: "Ucam Base 64U ByteString"
+
+instance ToJSON UcamBase64BS where
+ toJSON = toJSON . decodeUtf8 . unUcamB64
+ toEncoding = toEncoding . decodeUtf8 . unUcamB64
+
+newtype UcamBase64BSL = UcamB64L { unUcamB64L :: BSL.ByteString }
+ deriving stock (Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)
+
+{-|
+ Ensure ASCII text is not confused with other 'ByteString's
+-}
+newtype ASCII = ASCII { unASCII :: Text }
+ deriving stock (Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)
diff --git a/src/UcamWebauth/Data.hs b/src/UcamWebauth/Data.hs
new file mode 100644
--- /dev/null
+++ b/src/UcamWebauth/Data.hs
@@ -0,0 +1,605 @@
+{-# 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
diff --git a/src/UcamWebauth/Data/Internal.hs b/src/UcamWebauth/Data/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/UcamWebauth/Data/Internal.hs
@@ -0,0 +1,603 @@
+{-# OPTIONS_HADDOCK hide, not_here #-}
+{-# LANGUAGE
+ PackageImports
+ , DataKinds
+ , DeriveAnyClass
+ , DeriveDataTypeable
+ , DeriveGeneric
+ , DerivingStrategies
+ , GeneralizedNewtypeDeriving
+ , NamedFieldPuns
+ , NumDecimals
+ , OverloadedLists
+ , OverloadedStrings
+ , PatternSynonyms
+ , RecordWildCards
+ , TypeInType
+ , TypeOperators
+ #-}
+
+{-|
+Module : UcamWebauth.Internal
+Description : Internal use for Ucam Webauth data types
+Maintainer : David Baynard
+
+This module is *not* for general use.
+It is *not* considered part of the API.
+The only purpose is to allow core functionality to be split among various packages.
+
+Versions will not reflect changes to the API of this module.
+
+-}
+
+module UcamWebauth.Data.Internal
+ ( UcamWebauthInfo(..)
+
+ , AuthRequest(..)
+
+ , SignedAuthResponse(..)
+
+ , IsValid(..)
+
+ , AuthResponse(..)
+
+ , extractAuthInfo
+
+ , WLSVersion(..)
+ , displayWLSVersion
+ , bsDisplayWLSVersion
+
+ , AuthType(..)
+ , displayAuthType
+
+ , Ptag(..)
+ , displayPtag
+
+ , StatusCode(..)
+ , responseCodes
+ , getStatus
+ , noAuth510
+ , protoErr520
+ , paramErr530
+ , noInteract540
+ , unAuthAgent560
+ , declined570
+
+ , YesNo(..)
+ , displayYesNo
+ , bsDisplayYesNo
+
+ , YesOnly(YesOnly)
+ , displayYesOnly
+ , bsDisplayYesOnly
+
+ , KeyID(..)
+
+ , UcamTime(..)
+ , TimePeriod(..)
+ , secondsFromTimePeriod
+ , timePeriodFromSeconds
+
+ , WAAState(..)
+
+ , WAASettings(..)
+ , SetWAA
+ , configWAA
+ ) where
+
+import "base" Control.Applicative
+import "base" Control.Arrow ((&&&))
+import "deepseq" Control.DeepSeq (NFData, NFData1)
+import "mtl" Control.Monad.State
+import "aeson" Data.Aeson.Types
+import "bytestring" Data.ByteString (ByteString)
+import "this" Data.ByteString.B64
+import "base" Data.Char (toLower, isDigit)
+import "base" Data.Data
+import "containers" Data.IntMap (IntMap)
+import qualified "containers" Data.IntMap as IntMap
+import "base" Data.List.NonEmpty (NonEmpty)
+import "containers" Data.Map.Strict (Map)
+import qualified "containers" Data.Map.Strict as MapS
+import "base" Data.Maybe (fromMaybe)
+import "base" Data.String
+import "text" Data.Text (Text)
+import "text" Data.Text.Encoding
+import "text" Data.Text.Encoding.Error
+import "time" Data.Time
+import "base" GHC.Generics
+import "http-types" Network.HTTP.Types
+
+------------------------------------------------------------------------------
+-- * Core data types and associated functions
+
+------------------------------------------------------------------------------
+-- ** Return type
+
+{-|
+ 'UcamWebauthInfo' is returned from this module. The parameter 'a' represents data sent
+ in the initial connection, that must be returned. The constructor and accessors are *not*
+ exported from the module, to present an abstract API.
+-}
+data UcamWebauthInfo a = AuthInfo
+ { _approveUniq :: (UTCTime, Text)
+ , _approveUser :: Text
+ , _approveAttribs :: [Ptag]
+ , _approveLife :: Maybe TimePeriod
+ , _approveParams :: Maybe a
+ }
+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)
+ deriving anyclass (NFData, NFData1)
+
+instance ToJSON a => ToJSON (UcamWebauthInfo a)
+instance FromJSON a => FromJSON (UcamWebauthInfo a)
+
+------------------------------------------------------------------------------
+-- ** Request and response
+{- $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.
+-}
+
+{-|
+ An 'AuthRequest' is constructed by the @WAA@, using the constructor functions
+ of this module. The parameter represents data to be returned to the application
+ after authentication.
+-}
+data AuthRequest a = MakeAuthRequest
+ { _ucamQVer :: WLSVersion
+ , _ucamQUrl :: Text
+ , _ucamQDesc :: Maybe ASCII
+ , _ucamQAauth :: Maybe [AuthType]
+ , _ucamQIact :: Maybe YesNo
+ , _ucamQMsg :: Maybe Text
+ , _ucamQParams :: Maybe a
+ , _ucamQDate :: Maybe UTCTime
+ , _ucamQFail :: Maybe YesOnly
+ }
+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)
+ deriving anyclass (NFData, NFData1)
+
+{-|
+ A 'SignedAuthResponse' represents the data returned by the @WLS@, including a
+ representation of the content returned (in the 'AuthResponse' data type), and
+ the cryptographic signature, for verification.
+
+ The phantom parameter 'valid' corr
+-}
+data SignedAuthResponse (valid :: IsValid) a = SignedAuthResponse
+ { _ucamAResponse :: AuthResponse a
+ , _ucamAToSign :: ByteString
+ , _ucamAKid :: Maybe KeyID
+ , _ucamASig :: Maybe UcamBase64BS
+ }
+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)
+ deriving anyclass (NFData, NFData1)
+
+{-|
+ The intended use of this is with 'IsValid' as a kind (requires the 'DataKinds' extension).
+ The data constructors 'Valid' and 'MaybeValid' are now type constructors, which indicate the
+ validity of a 'SignedAuthResponse'.
+
+ This is not exported.
+-}
+data IsValid
+ = MaybeValid
+ | Valid
+ deriving stock (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)
+ deriving anyclass (NFData)
+
+{-|
+ An 'AuthResponse' represents the content returned by the @WLS@. The validation
+ machinery in this module returns the required data as a 'UcamWebauthInfo' value.
+-}
+data AuthResponse a = AuthResponse
+ { _ucamAVer :: WLSVersion
+ , _ucamAStatus :: StatusCode
+ , _ucamAMsg :: Maybe Text
+ , _ucamAIssue :: UTCTime
+ , _ucamAId :: Text
+ , _ucamAUrl :: Text
+ , _ucamAPrincipal :: Maybe Text
+ , _ucamAPtags :: [Ptag]
+ , _ucamAAuth :: Maybe AuthType
+ , _ucamASso :: Maybe (NonEmpty AuthType)
+ , _ucamALife :: Maybe TimePeriod
+ , _ucamAParams :: Maybe a
+ }
+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)
+ deriving anyclass (NFData, NFData1)
+
+{-|
+ Convert an 'AuthResponse' into a 'UcamWebauthInfo' for export.
+
+ This should not be exported. Instead export 'getAuthInfo'
+-}
+extractAuthInfo :: Alternative f => AuthResponse a -> f (UcamWebauthInfo a)
+extractAuthInfo AuthResponse{..} = maybe empty pure $ do
+ _approveUser <- _ucamAPrincipal
+ return AuthInfo{..}
+ where
+ _approveUniq = (_ucamAIssue, _ucamAId)
+ _approveAttribs = _ucamAPtags
+ _approveLife = _ucamALife
+ _approveParams = _ucamAParams
+
+------------------------------------------------------------------------------
+-- *** Protocol version
+
+{-|
+ Intended to be used as values, but Kind promotion means they can be used as types.
+-}
+data WLSVersion
+ = WLS1 -- ^ Version 1 of the protocol. In the Raven implementation, failures use this version
+ | WLS2 -- ^ Version 2
+ | WLS3 -- ^ Version 3. Used for successful reponses by the Raven implementation
+ deriving stock (Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)
+ deriving anyclass (NFData)
+
+instance Show WLSVersion where
+ show = displayWLSVersion
+
+{-|
+ Used for 'Show' instance.
+-}
+displayWLSVersion :: IsString a => WLSVersion -> a
+displayWLSVersion WLS1 = "1"
+displayWLSVersion WLS2 = "2"
+displayWLSVersion WLS3 = "3"
+
+{-|
+ Like the 'Show' instance, but typed to 'ByteString'.
+
+-}
+bsDisplayWLSVersion :: WLSVersion -> ByteString
+bsDisplayWLSVersion = displayWLSVersion
+
+wlsVersionAesonOptions :: Options
+wlsVersionAesonOptions = defaultOptions
+ { constructorTagModifier = drop 3
+ , sumEncoding = ObjectWithSingleField
+ }
+
+instance FromJSON WLSVersion where
+ parseJSON = genericParseJSON wlsVersionAesonOptions
+
+instance ToJSON WLSVersion where
+ toJSON = genericToJSON wlsVersionAesonOptions
+ toEncoding = genericToEncoding wlsVersionAesonOptions
+
+------------------------------------------------------------------------------
+-- *** Authentication types available
+
+{-|
+ An enumeration of valid authentication types. The protocol currently only defines one
+ valid type.
+-}
+data AuthType
+ = Pwd -- ^ pwd: Username and password
+ deriving stock (Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)
+ deriving anyclass (NFData)
+
+instance Show AuthType where
+ show = displayAuthType
+
+{-|
+ Implement show generically
+-}
+displayAuthType :: IsString a => AuthType -> a
+displayAuthType Pwd = "pwd"
+
+instance FromJSON AuthType where
+ parseJSON = genericParseJSON enumAesonOptions
+
+instance ToJSON AuthType where
+ toJSON = genericToJSON enumAesonOptions
+ toEncoding = genericToEncoding enumAesonOptions
+
+enumAesonOptions :: Options
+enumAesonOptions = defaultOptions
+ { constructorTagModifier = fmap toLower
+ , sumEncoding = UntaggedValue
+ , tagSingleConstructors = True
+ }
+
+------------------------------------------------------------------------------
+-- *** Data possibly useful for authorization (ptags)
+
+{-|
+ This is only in protocol versions ≥ 3
+-}
+data Ptag
+ = Current -- ^ User is current member of university
+ deriving stock (Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)
+ deriving anyclass (NFData)
+
+instance Show Ptag where
+ show = displayPtag
+
+{-|
+ Generic 'Show' implementation
+-}
+displayPtag :: IsString a => Ptag -> a
+displayPtag Current = "current"
+
+instance FromJSON Ptag where
+ parseJSON = genericParseJSON enumAesonOptions
+
+instance ToJSON Ptag where
+ toJSON = genericToJSON enumAesonOptions
+ toEncoding = genericToEncoding enumAesonOptions
+
+------------------------------------------------------------------------------
+-- *** HTTP response codes
+{- $statusCodes
+ A data type representing the HTTP status codes in the protocol. This is compatible
+ with the 'Status' type, but using the algebraic data type makes working with it
+ a little nicer.
+-}
+
+{-|
+ The valid HTTP status codes, according to the protocol.
+
+ 'BadRequest400' is present as a default, if there is any other code received.
+-}
+data StatusCode
+ = Ok200 -- ^ Authentication successful
+ | Gone410 -- ^ Cancelled by the user
+ | NoAuth510 -- ^ No mutually acceptable authentication types
+ | ProtoErr520 -- ^ Unsupported protocol version (Only for version 1)
+ | ParamErr530 -- ^ General request parameter error
+ | NoInteract540 -- ^ Interaction would be required but has been blocked
+ | UnAuthAgent560 -- ^ Application agent is not authorised
+ | Declined570 -- ^ Authentication declined
+ | BadRequest400 -- ^ Response not covered by any protocol responses
+ deriving stock (Show, Read, Eq, Ord, Bounded, Generic, Typeable, Data)
+ deriving anyclass (NFData)
+
+instance Enum StatusCode where
+ toEnum = fromMaybe BadRequest400 . flip IntMap.lookup responseCodes
+ fromEnum = statusCode . getStatus
+
+statusCodeAesonOptions :: Options
+statusCodeAesonOptions = defaultOptions
+ { constructorTagModifier = dropWhile (not . isDigit)
+ , sumEncoding = ObjectWithSingleField
+ }
+
+instance FromJSON StatusCode where
+ parseJSON = genericParseJSON statusCodeAesonOptions
+
+instance ToJSON StatusCode where
+ toJSON = genericToJSON statusCodeAesonOptions
+ toEncoding = genericToEncoding statusCodeAesonOptions
+
+
+{-|
+ An 'IntMap' of 'Status' code numbers in the protocol to their typed representations.
+-}
+responseCodes :: IntMap StatusCode
+responseCodes = IntMap.fromList . fmap (statusCode . getStatus &&& id) $
+ [Ok200, Gone410, NoAuth510, ProtoErr520, ParamErr530, NoInteract540, UnAuthAgent560, Declined570]
+
+{-|
+ Convert to the 'Status' type, defaulting to 'badRequest400' for a bad request
+-}
+getStatus :: StatusCode -> Status
+getStatus Ok200 = ok200
+getStatus Gone410 = gone410
+getStatus NoAuth510 = noAuth510
+getStatus ProtoErr520 = protoErr520
+getStatus ParamErr530 = paramErr530
+getStatus NoInteract540 = noInteract540
+getStatus UnAuthAgent560 = unAuthAgent560
+getStatus Declined570 = declined570
+getStatus _ = badRequest400
+
+------------------------------------------------------------------------------
+-- *** 'Status' values
+
+noAuth510, protoErr520, paramErr530, noInteract540, unAuthAgent560, declined570 :: Status
+noAuth510 = mkStatus 510 "No mutually acceptable authentication types"
+protoErr520 = mkStatus 520 "Unsupported protocol version (Only for version 1)"
+paramErr530 = mkStatus 530 "General request parameter error"
+noInteract540 = mkStatus 540 "Interaction would be required but has been blocked"
+unAuthAgent560 = mkStatus 560 "Application agent is not authorised"
+declined570 = mkStatus 570 "Authentication declined"
+
+------------------------------------------------------------------------------
+-- *** iact yes or no
+
+{-|
+ This is like a Boolean, but specifically for the ‘iact’ parameter
+-}
+data YesNo
+ = No
+ | Yes
+ deriving stock (Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)
+ deriving anyclass (NFData)
+
+instance Show YesNo where
+ show = displayYesNo
+
+displayYesNo :: IsString a => YesNo -> a
+displayYesNo Yes = "yes"
+displayYesNo _ = "no"
+
+{-|
+ Monomorphic variant of 'displayYesNo'
+-}
+bsDisplayYesNo :: YesNo -> ByteString
+bsDisplayYesNo = displayYesNo
+
+------------------------------------------------------------------------------
+-- *** fail yes
+
+{-|
+ Like '()' but specifically for the ‘iact’ parameter
+-}
+newtype YesOnly = YesOnly' ()
+ deriving stock (Read, Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Enum, Bounded, NFData)
+
+pattern YesOnly :: YesOnly
+pattern YesOnly = YesOnly' ()
+
+{-# COMPLETE YesOnly #-}
+
+instance Show YesOnly where
+ show = displayYesOnly
+
+displayYesOnly :: IsString a => YesOnly -> a
+displayYesOnly YesOnly = "yes"
+
+{-|
+ Monomorphic variant of 'displayYesOnly'
+-}
+bsDisplayYesOnly :: YesOnly -> ByteString
+bsDisplayYesOnly = displayYesOnly
+
+------------------------------------------------------------------------------
+-- *** Keys
+
+{-|
+ The key id, representing the public key for the @WLS@, is composed of a subset of 'ByteString' identifiers
+
+ Do not export constructors
+-}
+newtype KeyID = KeyID { unKeyID :: ByteString }
+ deriving stock (Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)
+
+instance FromJSON KeyID where
+ parseJSON = withObject "Key ID" $ \v -> KeyID . encodeUtf8
+ <$> v .: "Ucam Base 64U ByteString"
+
+instance ToJSON KeyID where
+ toJSON = toJSON . decodeUtf8With lenientDecode . unKeyID
+ toEncoding = toEncoding . decodeUtf8With lenientDecode . unKeyID
+
+------------------------------------------------------------------------------
+-- *** Time
+
+{-|
+ The modified UTCTime representation used in the protocol, based on RFC 3339. All
+ time zones are 'utc'.
+
+ Do not export constructor or accessor.
+-}
+newtype UcamTime = UcamTime { unUcamTime :: Text }
+ deriving stock (Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)
+
+{-|
+ 'DiffTime' with 'ToJSON' and 'FromJSON' instances.
+-}
+newtype TimePeriod = TimePeriod { timePeriod :: DiffTime }
+ deriving stock (Eq, Ord, Generic, Typeable, Data)
+ deriving newtype (Show, Num, NFData)
+
+secondsFromTimePeriod :: TimePeriod -> Integer
+secondsFromTimePeriod = round . timePeriod
+
+timePeriodFromSeconds :: Integer -> TimePeriod
+timePeriodFromSeconds = TimePeriod . secondsToDiffTime
+
+instance ToJSON TimePeriod where
+ toJSON = toJSON . secondsFromTimePeriod
+ toEncoding = toEncoding . secondsFromTimePeriod
+
+instance FromJSON TimePeriod where
+ parseJSON = withObject "Seconds" $ \v -> timePeriodFromSeconds
+ <$> v .: "Seconds"
+
+------------------------------------------------------------------------------
+-- * 'WAASettings' and lenses
+
+{-|
+ The state involved in authentication. This includes the settings as 'WAASettings' and
+ the request as 'AuthRequest'.
+
+ Do not export constructors or accessors, only lenses.
+-}
+data WAAState a = MakeWAAState
+ { _wSet :: WAASettings
+ , _aReq :: AuthRequest a
+ --, _aSrs :: SignedAuthResponse valid a
+ }
+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)
+ deriving anyclass (NFData, NFData1)
+
+{-|
+ The settings for the application.
+
+ Do not export constructors or accessors, only lenses.
+ TODO Make urls type safe
+-}
+data WAASettings = MakeWAASettings
+ { _authAccepted :: [AuthType]
+ , _needReauthentication :: Maybe YesNo
+ , _syncTimeOut :: NominalDiffTime
+ , _validKids :: [KeyID]
+ , _recentTime :: UTCTime
+ , _applicationUrl :: Text
+ , _wlsUrl :: Text
+ , _importedKeys :: Map KeyID ByteString
+ , _ucamWebauthHeader :: Maybe ByteString
+ }
+ deriving stock (Show, Eq, Ord, Generic, Typeable, Data)
+ deriving anyclass (NFData)
+
+{-|
+ Type synonym for WAASettings settings type.
+-}
+type SetWAA a = State (WAAState a) ()
+
+{-|
+ The default @WAA@ settings. To accept the defaults, use
+
+ > configWAA def
+
+ or
+
+ > configWAA . return $ ()
+
+ To modify settings, use the provided lenses.
+
+ 'configWAA' should not be exported. Instead, all functions requiring settings
+ should use this function in a view pattern.
+-}
+configWAA :: SetWAA a -> WAAState a
+configWAA = flip execState MakeWAAState
+ { _wSet = settings
+ , _aReq = request
+ }
+
+ where
+ settings :: WAASettings
+ settings = MakeWAASettings
+ { _authAccepted = [Pwd]
+ , _needReauthentication = Nothing
+ , _syncTimeOut = 40
+ , _validKids = empty
+ , _recentTime = error "You must assign a time to check the issue time of a response is valid."
+ , _applicationUrl = mempty
+ , _wlsUrl = error "You must enter a URL for the authentication server."
+ , _importedKeys = MapS.empty
+ , _ucamWebauthHeader = empty
+ }
+
+ request :: AuthRequest a
+ request = MakeAuthRequest
+ { _ucamQVer = WLS3
+ , _ucamQUrl = error "You must enter a URL for the application wishing to authenticate the user."
+ , _ucamQDesc = pure "This should be the ASCII description of the application requesting authentication"
+ , _ucamQAauth = empty
+ , _ucamQIact = empty
+ , _ucamQMsg = pure "This should be the reason authentication is requested."
+ , _ucamQParams = empty
+ , _ucamQDate = empty
+ , _ucamQFail = pure YesOnly
+ }
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/ucam-webauth-types.cabal b/ucam-webauth-types.cabal
new file mode 100644
--- /dev/null
+++ b/ucam-webauth-types.cabal
@@ -0,0 +1,78 @@
+cabal-version: 2.2
+name: ucam-webauth-types
+version: 0.1.0.0
+license: (BSD-3-Clause OR Apache-2.0)
+license-file: LICENSE
+copyright: 2018 David Baynard
+maintainer: David Baynard
+author: David Baynard
+homepage: https://github.com/dbaynard/UcamWebauth#readme
+bug-reports: https://github.com/dbaynard/UcamWebauth/issues
+synopsis: Types for the Ucam-Webauth protocol, as used by Raven
+description:
+ Types for the implementation of the Ucam-Webauth protocol, as used by the
+ University of Cambridge’s Raven authentication service.
+category: Web
+build-type: Simple
+extra-source-files:
+ Changelog.md
+ README.md
+
+source-repository head
+ type: git
+ location: https://github.com/dbaynard/UcamWebauth
+
+flag dev
+ description:
+ Compile for development
+ default: False
+ manual: True
+
+library
+ exposed-modules:
+ Data.ByteString.B64
+ UcamWebauth.Data
+ UcamWebauth.Data.Internal
+ hs-source-dirs: src
+ default-language: Haskell2010
+ ghc-options: -Wall -Wincomplete-uni-patterns
+ -Wincomplete-record-updates -Wcompat -Wnoncanonical-monad-instances
+ -Wnoncanonical-monadfail-instances
+ build-depends:
+ aeson >=1.2 && <1.5,
+ base >=4.11.0.0 && <4.12,
+ base64-bytestring >=1.0.0.1 && <1.1,
+ bytestring >=0.10.8.2 && <0.11,
+ case-insensitive >=1.2.0.11 && <1.3,
+ containers >=0.5.11.0 && <0.6,
+ deepseq >=1.4.3.0 && <1.5,
+ http-types >=0.12.1 && <0.13,
+ microlens >=0.4.9.1 && <0.5,
+ microlens-mtl >=0.1.11.1 && <0.2,
+ mtl >=2.2.2 && <2.3,
+ text >=0.11 && <1.2.3.0 || >=1.2.3.1 && <1.3,
+ time >=1.9.2 && <1.10,
+ timerep >=2.0.0.2 && <2.1
+
+ if flag(dev)
+ ghc-options: -ddump-minimal-imports
+
+test-suite test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ build-tool-depends: hspec-discover:hspec-discover -any
+ hs-source-dirs: test
+ other-modules:
+ Paths_ucam_webauth_types
+ autogen-modules:
+ Paths_ucam_webauth_types
+ default-language: Haskell2010
+ ghc-options: -Wall -Wincomplete-uni-patterns
+ -Wincomplete-record-updates -Wcompat -Wnoncanonical-monad-instances
+ -Wnoncanonical-monadfail-instances
+ build-depends:
+ base >=4.11.0.0 && <4.12,
+ hspec >=2.0.0 && <2.6
+
+ if flag(dev)
+ ghc-options: -ddump-minimal-imports