module Crypto.Persona
(
RelativeURI()
, parseRelativeURI
, DelegatedSupportDocument(DelegatedSupportDocument)
, authority
, SupportDocument
, publicKey
, authentication
, provisioning
, supportDocument
, Principal(..)
, certify
, provisioningApiJsUrl
, authenticationApiJsUrl
) where
import Prelude hiding (exp)
import Control.Applicative
import Control.Lens hiding ((.=))
import Data.Aeson
import Data.Default.Class (def)
import qualified Data.Text as T
import Data.Time
import Data.Time.Clock.POSIX
import Network.URI (URI, parseRelativeReference)
import Crypto.JOSE
import Crypto.JOSE.Legacy
import Crypto.JWT
newtype RelativeURI = RelativeURI URI deriving (Eq)
instance Show RelativeURI where
show (RelativeURI uri) = show uri
instance FromJSON RelativeURI where
parseJSON = withText "URI" $
maybe (fail "not a relative URI") pure . parseRelativeURI . T.unpack
instance ToJSON RelativeURI where
toJSON (RelativeURI uri) = String $ T.pack $ show uri
parseRelativeURI :: String -> Maybe RelativeURI
parseRelativeURI = fmap RelativeURI . Network.URI.parseRelativeReference
data SupportDocument = SupportDocument
{ _publicKey :: JWK'
, _authentication :: RelativeURI
, _provisioning :: RelativeURI
}
makeLenses ''SupportDocument
instance FromJSON SupportDocument where
parseJSON = withObject "SupportDocument" (\o -> SupportDocument
<$> o .: "public-key"
<*> o .: "authentication"
<*> o .: "provisioning")
instance ToJSON SupportDocument where
toJSON (SupportDocument k a p) = object
[ "public-key" .= k
, "authentication" .= a
, "provisioning" .= p
]
supportDocument :: JWK' -> RelativeURI -> RelativeURI -> Maybe SupportDocument
supportDocument k a p = publicKey public $ SupportDocument k a p
newtype DelegatedSupportDocument = DelegatedSupportDocument
{ _authority :: String
} deriving (Eq, Show)
makeLenses ''DelegatedSupportDocument
instance FromJSON DelegatedSupportDocument where
parseJSON = withObject "DelegatedSupportDocument" $ \o ->
DelegatedSupportDocument <$> o .: "authority"
instance ToJSON DelegatedSupportDocument where
toJSON (DelegatedSupportDocument s) = object [ "authority" .= s ]
data Principal = EmailPrincipal T.Text | HostPrincipal T.Text
instance FromJSON Principal where
parseJSON = withObject "Principal" (\o ->
EmailPrincipal <$> o .: "email"
<|> HostPrincipal <$> o .: "host")
instance ToJSON Principal where
toJSON (EmailPrincipal s) = object ["email" .= s]
toJSON (HostPrincipal s) = object ["host" .= s]
certify
:: CPRG g
=> g
-> JWK'
-> StringOrURI
-> UTCTime
-> Integer
-> Value
-> Principal
-> (Either Error JWT, g)
certify g k iss t dur pk principal =
createJWSJWT g (toJWK k) header claims
where
claims = emptyClaimsSet
& claimIss .~ Just iss
& claimExp .~ Just exp
& claimIat .~ Just iat
& addClaim "public-key" (toJSON pk)
& addClaim "principal" (toJSON principal)
header = def { headerAlg = Just RS256 }
exp = toMs $ addUTCTime (fromRational $ toRational $ min dur 86400) t
iat = toMs t
toMs = NumericDate . posixSecondsToUTCTime . (* 1000) . utcTimeToPOSIXSeconds
provisioningApiJsUrl :: String
provisioningApiJsUrl = "https://login.persona.org/provisioning_api.js"
authenticationApiJsUrl :: String
authenticationApiJsUrl = "https://login.persona.org/provisioning_api.js"