packages feed

persona-idp 0.1.0.0 → 0.1.0.1

raw patch · 9 files changed

+426/−1 lines, 9 files

Files

persona-idp.cabal view
@@ -1,5 +1,5 @@ name:                persona-idp-version:             0.1.0.0+version:             0.1.0.1 synopsis:            Persona (BrowserID) Identity Provider description:   .@@ -16,6 +16,8 @@ license-file:        agpl-3.0.txt extra-source-files:   README.rst+  src/provisioning.hamlet+  src/provisioning.julius author:              Fraser Tweedale maintainer:          frase@frase.id.au copyright:           Copyright (C) 2013, 2014, 2015  Fraser Tweedale@@ -60,3 +62,10 @@    hs-source-dirs:      src   main-is:             Main.hs+  other-modules:+    Command+    Config+    Init+    Middleware+    Provision+    Serve
+ src/Command.hs view
@@ -0,0 +1,23 @@+-- This file is part of persona-idp - Persona (BrowserID) Identity Provider+-- Copyright (C) 2013  Fraser Tweedale+--+-- persona-idp is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module Command where++import Options.Applicative++class Command a where+  run :: a -> IO ()+  parser :: Parser a
+ src/Config.hs view
@@ -0,0 +1,54 @@+-- This file is part of persona-idp - Persona (BrowserID) Identity Provider+-- Copyright (C) 2013  Fraser Tweedale+--+-- persona-idp is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module Config+  (+    ensureConfigDir+  , readConfig+  , readConfigJSON+  , writeConfig+  , writeConfigJSON+  ) where++import Control.Monad++import Data.Aeson+import qualified Data.ByteString.Lazy as L+import System.FilePath.Posix+import System.Directory+import System.Posix.Files (setFileCreationMask)+++personaDir :: IO String+personaDir = getAppUserDataDirectory "persona-idp"++ensureConfigDir :: IO ()+ensureConfigDir = personaDir >>= createDirectoryIfMissing False++readConfig :: String -> IO L.ByteString+readConfig n = personaDir >>= L.readFile . (</> n)++readConfigJSON :: FromJSON a => String -> IO (Either String a)+readConfigJSON = liftM eitherDecode . readConfig++writeConfig :: String -> L.ByteString -> IO ()+writeConfig n s = do+  _ <- setFileCreationMask 0o0077+  dir <- personaDir+  L.writeFile (dir </> n) s++writeConfigJSON :: ToJSON a => String -> a -> IO ()+writeConfigJSON s = writeConfig s . encode
+ src/Init.hs view
@@ -0,0 +1,61 @@+-- This file is part of persona-idp - Persona (BrowserID) Identity Provider+--+-- Copyright (C) 2013, 2014  Fraser Tweedale+--+-- persona-idp is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}++module Init where++import System.Exit++import Options.Applicative++import Crypto.JOSE+import Crypto.Persona++import Command+import Config++data InitOpts = InitOpts String String++instance Command InitOpts where+  parser = InitOpts+    <$> strOption+      ( long "app-path"+      <> metavar "PATH"+      <> help "Path at which the app is hosted, e.g. \"/browserid\""+      )+    <*> strOption+      ( long "hostname"+      <> metavar "HOSTNAME"+      <> help "Hostname of the authority"+      )+  run (InitOpts appPath host) =+    let+      buildURIPath s = '/' : dropWhile (== '/') (appPath ++ "/" ++ s)+      buildURI = parseRelativeURI . buildURIPath+    in do+      entropyPool <- createEntropyPool+      let g = cprgCreate entropyPool :: SystemRNG+          (k, _) = gen 256 g  -- jwcrypto does not support keys > 2048 bits+      auth <- maybe exitFailure return $ buildURI "authentication"+      prov <- maybe exitFailure return $ buildURI "provisioning"+      ensureConfigDir+      maybe exitFailure (writeConfigJSON "support.json") $+        supportDocument k auth prov+      writeConfigJSON "delegated-support.json" $+        DelegatedSupportDocument host+      writeConfigJSON "key.json" k
+ src/Middleware.hs view
@@ -0,0 +1,100 @@+-- This file is part of persona-idp - Persona (BrowserID) Identity Provider+-- Copyright (C) 2015  Fraser Tweedale+--+-- persona-idp is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}++module Middleware+  (+    remoteUserX509Middleware+  , certLookupEmail+  ) where++import Control.Applicative+import Control.Monad+import Data.Foldable+import Data.Monoid++import Data.ASN1.Types.String+import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.PEM+import Data.X509+import Network.HTTP.Types+import Network.Wai++data RemoteUserLookup = RemoteUserLookup+  HeaderName+  (B.ByteString -> Maybe B.ByteString)++remoteUserLookupX509 :: RemoteUserLookup+remoteUserLookupX509 = RemoteUserLookup "SSL_CLIENT_CERT" f+  where+  f = either (const Nothing) getEmail+    . (decodeSignedCertificate <=< content <=< pemParseBS . B.map tabToLf)+  getEmail = fmap (T.encodeUtf8 . T.pack) . certLookupEmail . getCertificate+  content [] = Left "nothing to see here"+  content (x:_) = Right (pemContent x)+  tabToLf 9 = 10+  tabToLf c = c++certLookupEmail :: Certificate -> Maybe String+certLookupEmail a = sanEmail a <|> sdnEmail a+  where+  sdnEmail = asn1CharacterToString+    <=< lookup [1,2,840,113549,1,9,1] . getDistinguishedElements . certSubjectDN+  sanEmail = findEmailAltName <=< extensionGet . certExtensions+  findEmailAltName (ExtSubjectAltName names) =+    getFirst (foldMap (First . rfc822AltName) names)+  rfc822AltName (AltNameRFC822 s) = Just s+  rfc822AltName _ = Nothing++lookupRemoteUser :: RemoteUserLookup -> Request -> Maybe B.ByteString+lookupRemoteUser (RemoteUserLookup k f) =+  f <=< lookup k . requestHeaders++-- | Create a 'Middleware' from a 'RemoteUserLookup'+--+-- The middleware triggers if the request does not contain the+-- "REMOTE_USER" header.  The first successful lookup causes the+-- result to be stored in this header, so subsequent middlewares+-- will not have effect.+--+-- Note that header names are case-insensitive.+--+remoteUserLookupMiddleware :: RemoteUserLookup -> Middleware+remoteUserLookupMiddleware a = (. modreq)+  where+  modreq req =+    let+      hs = requestHeaders req+      k = "REMOTE_USER"+    in+      case lookup k hs of+        Just _ -> req+        Nothing -> case lookupRemoteUser a req of+          Nothing -> req+          Just s -> req { requestHeaders = (k, s) : hs }++-- | Copies email address from a PEM-encoded X.509 certificate+-- provided via the SSL_CLIENT_CERT header.  The Subject Alternative+-- Name extension is preferred over the (deprecated) Subject DN+-- email component.+--++remoteUserX509Middleware :: Middleware+remoteUserX509Middleware =+  remoteUserLookupMiddleware remoteUserLookupX509
+ src/Provision.hs view
@@ -0,0 +1,61 @@+-- This file is part of persona-idp - Persona (BrowserID) Identity Provider+-- Copyright (C) 2014  Fraser Tweedale+--+-- persona-idp is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Provision+  (+    ProvisioningRequest(ProvisioningRequest)+  , eml+  , pub+  , dur++  , provision+  ) where++import Control.Applicative++import Control.Lens hiding ((.=))+import Data.Aeson+import qualified Data.Text as T+import Data.Time++import Crypto.Random+import Crypto.JOSE+import Crypto.JOSE.Legacy+import Crypto.JWT+import Crypto.Persona++data ProvisioningRequest = ProvisioningRequest+  { _eml :: T.Text+  , _pub :: Value+  , _dur :: Integer+  }+makeLenses ''ProvisioningRequest++instance FromJSON ProvisioningRequest where+  parseJSON = withObject "ProvisioningRequest"$ \o -> ProvisioningRequest+    <$> o .: "eml"+    <*> o .: "pub"+    <*> o .: "dur"++provision :: JWK' -> StringOrURI -> ProvisioningRequest -> IO (Either Error JWT)+provision k iss ProvisioningRequest{..} = do+  g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+  t <- getCurrentTime+  return $ fst $ certify g k iss t _dur _pub (EmailPrincipal _eml)
+ src/Serve.hs view
@@ -0,0 +1,94 @@+-- This file is part of persona-idp - Persona (BrowserID) Identity Provider+-- Copyright (C) 2013, 2014, 2015  Fraser Tweedale+--+-- persona-idp is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Serve (ServeOpts) where++import Control.Monad.IO.Class+import System.Exit++import Control.Lens+import Data.Aeson (eitherDecode, toJSON)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Network.HTTP.Types.Status+import Options.Applicative hiding (header)+import Text.Blaze.Renderer.Text+import Text.Hamlet+import Text.Julius+import Web.Scotty++import Crypto.JOSE (encodeCompact)+import Crypto.JWT (fromString)+import Crypto.Persona++import Command+import Config+import Middleware+import Provision++data ServeOpts = ServeOpts Int++instance Command ServeOpts where+  parser = ServeOpts+    <$> option+      ( long "port"+      <> value 3000+      <> showDefault+      <> metavar "N"+      <> help "Port on which to listen"+      )+  run (ServeOpts port) = do+    let handleError = either (\e -> print e >> exitFailure) return+    delegatedSupport <- handleError =<< readConfigJSON "delegated-support.json"+    support <- handleError =<< readConfigJSON "support.json"+    k <- handleError =<< readConfigJSON "key.json"++    scotty port $ do+      middleware remoteUserX509Middleware++      get "/delegated-support" $ json delegatedSupport+      get "/support" $ json support+      get "/.well-known/browserid" $ json support++      get "/provisioning" $+        html $ renderMarkup $(shamletFile "src/provisioning.hamlet")++      get "/provisioning.js" $ do+        let template = $(juliusFile "src/provisioning.julius")+        text $ renderJavascriptUrl (\_ _ -> undefined) template+        setHeader "Content-Type" "text/javascript; charset=UTF-8"++      post "/provisioning" $ do+        provReq' <- body+        case eitherDecode provReq' of+          Left e -> respondWith badRequest400 e+          Right provReq -> do+            remoteUser <- header "REMOTE_USER"+            if remoteUser == Just (TL.fromStrict $ provReq ^. eml)+            then do+              let iss = fromString $ T.pack $ delegatedSupport ^. authority+              result <- liftIO ((>>= encodeCompact) <$> provision k iss provReq)+              case result of+                Left e -> respondWith internalServerError500 (show e)+                Right cert -> raw cert+            else+              status forbidden403++respondWith :: Status -> String -> ActionM ()+respondWith e s = status e >> text (TL.pack $ show s)
+ src/provisioning.hamlet view
@@ -0,0 +1,8 @@+$doctype 5+<html>+    <head>+        <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">+        <script type="text/javascript" src="#{provisioningApiJsUrl}">+        <script type="text/javascript" src="#{show (support ^. provisioning) ++ ".js"}">+    <body>+        <h1>HI
+ src/provisioning.julius view
@@ -0,0 +1,15 @@+(function() {+  navigator.id.beginProvisioning(function(eml, dur) {+    navigator.id.genKeyPair(function(pub) {+      var xhr = new XMLHttpRequest();+      xhr.open('POST', #{toJSON $ support ^. provisioning});+      xhr.onreadystatechange = function () {+        var DONE = this.DONE || 4;+        if (this.readyState === DONE) {+          navigator.id.registerCertificate(this.responseText);+        }+      };+      xhr.send(JSON.stringify({eml: eml, pub: JSON.parse(pub), dur: dur}));+    });+  });+})();