diff --git a/config/models b/config/models index 4383c35..26beec3 100644 --- a/config/models +++ b/config/models @@ -39,6 +39,12 @@ Person UniquePersonLogin login UniquePersonEmail email +VerifKey + ident URI + public PublicKey + + UniqueVerifKey ident + SshKey ident KyIdent person PersonId diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model new file mode 100644 index 0000000..48dbcfa --- /dev/null +++ b/migrations/2019_02_03_verifkey.model @@ -0,0 +1,5 @@ +VerifKey + ident String + public ByteString + + UniqueVerifKey ident diff --git a/src/Database/Persist/Class/Local.hs b/src/Database/Persist/Class/Local.hs index 78312b8..d709682 100644 --- a/src/Database/Persist/Class/Local.hs +++ b/src/Database/Persist/Class/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -13,7 +13,6 @@ - . -} --- | 'PersistField' instance for 'CI', for easy case-insensitive DB fields. module Database.Persist.Class.Local ( ) @@ -21,11 +20,46 @@ where import Prelude +import Control.Exception (displayException) +import Control.Monad ((<=<)) +import Crypto.Error (CryptoFailable, eitherCryptoError) +import Crypto.PubKey.Ed25519 (PublicKey, publicKey) +import Data.Bifunctor (first) +import Data.ByteArray (convert) +import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Database.Persist.Class +import Network.URI (URI, uriScheme, parseURI) import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T (pack) + +import Data.Aeson.Local (renderURI) instance (PersistField s, CI.FoldCase s) => PersistField (CI s) where toPersistValue = toPersistValue . CI.original fromPersistValue = fmap CI.mk . fromPersistValue + +instance PersistField URI where + toPersistValue = toPersistValue . renderURI + fromPersistValue = parseHttpsURI <=< fromPersistValue + where + parseHttpsURI s = + case parseURI s of + Nothing -> Left "Invalid absolute URI" + Just u -> + if uriScheme u == "https:" + then Right u + else Left "URI scheme isn't https" + +instance PersistField PublicKey where + toPersistValue = toPersistValue . convert' + where + convert' :: PublicKey -> ByteString + convert' = convert + fromPersistValue = toKey <=< fromPersistValue + where + publicKey' :: ByteString -> CryptoFailable PublicKey + publicKey' = publicKey + toKey = + first (T.pack . displayException) . eitherCryptoError . publicKey' diff --git a/src/Database/Persist/Sql/Local.hs b/src/Database/Persist/Sql/Local.hs index aa897f8..541450e 100644 --- a/src/Database/Persist/Sql/Local.hs +++ b/src/Database/Persist/Sql/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -20,12 +20,26 @@ where import Prelude +import Crypto.PubKey.Ed25519 (PublicKey) +import Data.ByteArray (convert) +import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Database.Persist.Sql +import Network.URI (URI) import qualified Data.CaseInsensitive as CI +import Data.Aeson.Local (renderURI) import Database.Persist.Class.Local () instance (PersistFieldSql s, CI.FoldCase s) => PersistFieldSql (CI s) where sqlType = sqlType . fmap CI.original + +instance PersistFieldSql URI where + sqlType = sqlType . fmap renderURI + +instance PersistFieldSql PublicKey where + sqlType = sqlType . fmap convert' + where + convert' :: PublicKey -> ByteString + convert' = convert diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 2e5f14f..91f2ddb 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -576,46 +576,54 @@ instance YesodHttpSig App where u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of Nothing -> Left "keyId in Sig header isn't a valid absolute URI" Just uri -> Right uri - manager <- getsYesod appHttpManager - actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u + let uActor = u { uriFragment = "" } + (fromDB, key) <- do + ment <- lift $ runDB $ getBy $ UniqueVerifKey u + case ment of + Just (Entity _ vk) -> return (True, verifKeyPublic vk) + Nothing -> do + manager <- getsYesod appHttpManager + actor <- ExceptT $ bimap displayException responseBody <$> httpGetAP manager u + ExceptT . pure $ do + if uActor == actorId actor + then Right () + else Left "Actor ID doesn't match the keyid URI we fetched" + let pkey = actorPublicKey actor + if publicKeyShared pkey + then Left "Actor's publicKey is shared, we're rejecting it!" + else Right () + if publicKeyId pkey == u + then Right () + else Left "Actor's publicKey's ID doesn't match the keyid URI" + if publicKeyOwner pkey == actorId actor + then Right () + else Left "Actor's publicKey's owner doesn't match the actor's ID" + case publicKeyAlgo pkey of + Nothing -> + Left $ + case malgo of + Nothing -> "Algo not given in Sig nor actor" + Just _ -> "Algo mismatch, Ed25519 in Sig but none in actor" + Just algo -> + case algo of + AlgorithmEd25519 -> Right () + AlgorithmOther _ -> + Left $ + case malgo of + Nothing -> "No algo in Sig, unsupported algo in actor" + Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" + case publicKey $ pemContent $ publicKeyPem pkey of + CryptoPassed k -> Right (False, k) + CryptoFailed e -> Left "Parsing Ed25519 public key failed" ExceptT . pure $ do - let uActor = u { uriFragment = "" } - if uActor == actorId actor - then Right () - else Left "Actor ID doesn't match the keyid URI we fetched" - let pkey = actorPublicKey actor - if publicKeyShared pkey - then Left "Actor's publicKey is shared, we're rejecting it!" - else Right () - if publicKeyId pkey == u - then Right () - else Left "Actor's publicKey's ID doesn't match the keyid URI" - if publicKeyOwner pkey == actorId actor - then Right () - else Left "Actor's publicKey's owner doesn't match the actor's ID" - case publicKeyAlgo pkey of - Nothing -> - Left $ - case malgo of - Nothing -> "Algo not given in Sig nor actor" - Just _ -> "Algo mismatch, Ed25519 in Sig but none in actor" - Just algo -> - case algo of - AlgorithmEd25519 -> Right () - AlgorithmOther _ -> - Left $ - case malgo of - Nothing -> "No algo in Sig, unsupported algo in actor" - Just _ -> "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" - key <- case publicKey $ pemContent $ publicKeyPem pkey of - CryptoPassed k -> Right k - CryptoFailed e -> Left "Parsing Ed25519 public key failed" signature <- case signature sig of CryptoPassed s -> Right s CryptoFailed e -> Left "Parsing Ed25519 signature failed" if verify key input signature - then Right uActor + then Right () else Left "Ed25519 sig verification says not valid" + unless fromDB $ lift $ runDB $ insert_ $ VerifKey u key + return uActor instance YesodBreadcrumbs App where breadcrumb route = return $ case route of diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 5cbb703..36cb61a 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -187,6 +187,8 @@ changes = , removeEntity "RepoRoleInherit" -- 40 , removeEntity "RepoRole" + -- 41 + , addEntities model_2019_02_03_verifkey ] migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int)) diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index b5b6be8..dd19ddf 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -20,6 +20,7 @@ module Vervis.Migration.Model , Workflow2016Generic (..) , Workflow2016 , model_2016_09_01_rest + , model_2019_02_03_verifkey ) where @@ -57,3 +58,6 @@ model_2016_09_01_rest = $(schema "2016_09_01_rest") makeEntitiesMigration "2018" $(modelFile "migrations/2019_01_28_project_collabs.model") + +model_2019_02_03_verifkey :: [Entity SqlBackend] +model_2019_02_03_verifkey = $(schema "2019_02_03_verifkey") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 3ce9f75..d2da976 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -20,8 +20,10 @@ module Vervis.Model where import ClassyPrelude.Conduit import Yesod hiding (Header, parseTime) +import Crypto.PubKey.Ed25519 (PublicKey) import Database.Persist.Quasi import Database.Persist.Sql (fromSqlKey) +import Network.URI (URI) import Text.Email.Validate (EmailAddress) import Yesod.Auth.Account (PersistUserCredentials (..))