From 61d1aa67209317aed7223ee0cd88ed20d4ef7184 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sat, 9 Mar 2019 21:21:36 +0000
Subject: [PATCH] Define HMAC based access token and switch CapSignKey from
 Ed25519 to HMAC

---
 src/Vervis/Foundation.hs  |  3 +-
 src/Web/ActivityAccess.hs | 89 +++++++++++++++++++++++++++++++++++++++
 vervis.cabal              |  1 +
 3 files changed, 92 insertions(+), 1 deletion(-)
 create mode 100644 src/Web/ActivityAccess.hs

diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 9464499..6a4c757 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -64,6 +64,7 @@ import Yesod.Mail.Send
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
 import Network.FedURI
+import Web.ActivityAccess
 import Web.ActivityPub hiding (PublicKey)
 
 import Text.Email.Local
@@ -92,7 +93,7 @@ data App = App
     , appSvgFont      :: PreparedFont Double
     , appActorKeys    :: TVar (ActorKey, ActorKey, Bool)
     , appInstanceMutex :: InstanceMutex
-    , appCapSignKey   :: ActorKey
+    , appCapSignKey   :: AccessTokenSecretKey
     , appHashidEncode :: Int64 -> Text
     , appHashidDecode :: Text -> Maybe Int64
 
diff --git a/src/Web/ActivityAccess.hs b/src/Web/ActivityAccess.hs
new file mode 100644
index 0000000..dd42310
--- /dev/null
+++ b/src/Web/ActivityAccess.hs
@@ -0,0 +1,89 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Web.ActivityAccess
+    ( SignedAccessToken ()
+    , AccessTokenSecretKey ()
+    , encodeSignedAccessToken
+    , decodeSignedAccessToken
+    , signAccessToken
+    , verifyAccessToken
+    )
+where
+
+import Prelude
+
+import Crypto.Hash
+import Crypto.MAC.HMAC
+import Crypto.Random
+import Data.ByteString (ByteString)
+import Data.KeyFile
+
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as BC
+
+data SignedAccessToken = SignedAccessToken
+    { _accessTokenMsg  :: ByteString
+    , _accessTokenHMAC :: HMAC SHA256
+    }
+
+newtype AccessTokenSecretKey = AccessTokenSecretKey ByteString
+
+instance KeyFile AccessTokenSecretKey where
+    generateKey = AccessTokenSecretKey <$> getRandomBytes 32
+    parseKey b =
+        if B.length b == 32
+            then return $ AccessTokenSecretKey b
+            else fail "AccessTokenSigningKey parseKey invalid length"
+    renderKey (AccessTokenSecretKey b) = b
+
+encodeSignedAccessToken :: SignedAccessToken -> ByteString
+encodeSignedAccessToken (SignedAccessToken msg sig) = B.concat
+    [ msg
+    , "-"
+    , B64.encode $ BA.convert sig
+    ]
+
+decodeSignedAccessToken :: ByteString -> Either String SignedAccessToken
+decodeSignedAccessToken token = do
+    let (msg, rest) = BC.break (== '-') token
+    sigB64 <-
+        case B.stripPrefix "-" rest of
+            Nothing -> err "Invalid format, separator not found"
+            Just rest' -> return rest'
+    sigBin <-
+        case B64.decode sigB64 of
+            Left s -> err $ "Base64 decoding sig failed: " ++ s
+            Right b -> return b
+    digest <-
+        case digestFromByteString sigBin of
+            Nothing -> err "Decoding sig hash failed, invalid length"
+            Just d -> return d
+    return $ SignedAccessToken msg $ HMAC digest
+    where
+    err s = Left $ "decodeSignedAccessToken: " ++ s
+
+signAccessToken :: AccessTokenSecretKey -> ByteString -> SignedAccessToken
+signAccessToken (AccessTokenSecretKey key) msg =
+    SignedAccessToken msg $ hmac key msg
+
+verifyAccessToken
+    :: AccessTokenSecretKey -> SignedAccessToken -> Maybe ByteString
+verifyAccessToken (AccessTokenSecretKey key) (SignedAccessToken msg sig) =
+    if hmac key msg == sig
+        then Just msg
+        else Nothing
diff --git a/vervis.cabal b/vervis.cabal
index a0d97cb..f477e0d 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -86,6 +86,7 @@ library
                        Text.Email.Local
                        Text.FilePath.Local
                        Text.Jasmine.Local
+                       Web.ActivityAccess
                        Web.ActivityPub
                        Web.Hashids.Local
                        Web.PathPieces.Local