a couple of signature tests

.dir-locals.el

@@ -1,5 +1,7 @@
 (
   ("src" .  ((nil . ((dante-target . "fedi")))))
 
-  ("app" .  ((nil . ((dante-target . "exe:fedi")))))
+  ("app" .  ((nil . ((dante-target . "exe:fediserve")))))
+
+  ("test" .  ((nil . ((dante-target . "test:fedi-test")))))
 )

Makefile

@@ -2,7 +2,7 @@
 format:
 	find ./src -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
 	find ./app -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
-	# find ./test -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
+	find ./test -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
 
 .PHONY: clean
 clean:
@@ -12,15 +12,19 @@ clean:
 build: fedi.cabal cabal.project
 	cabal build all --enable-tests --enable-benchmarks
 
+.PHONY: test
+test:
+	cabal test --test-show-details=direct
+
 .PHONY: serve
 serve:
-	FEDI_DETAILS="test/public/details.json" cabal run fedi -- serve
+	FEDI_DETAILS="test/public/details.json" cabal run fediserve -- serve
 
 .PHONY: insert
 insert:
-	FEDI_DETAILS="test/public/details.json" cabal run fedi -- insert note.html
+	FEDI_DETAILS="test/public/details.json" cabal run fediserve -- insert note.html
 
 .PHONY: docker
 docker: fedi.cabal cabal.project clean
 	DOCKER_BUILDKIT=1 docker build -o ./out/ .
-	file out/fedi
+	file out/fediserve

cabal.project

@@ -1,3 +1,5 @@
 packages: *.cabal
 
 constraints: cryptostore +use_crypton
+
+tests: True

fedi.cabal

@@ -83,7 +83,7 @@ library
     DuplicateRecordFields
     NoFieldSelectors
 
-executable fedi
+executable fediserve
   import: warnings
   main-is: Main.hs
   other-modules:
@@ -122,3 +122,35 @@ executable fedi
     DuplicateRecordFields
     NoFieldSelectors
   ghc-options: -Wall -O -threaded -rtsopts -with-rtsopts=-N
+
+test-suite fedi-test
+  type: exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is: Spec.hs
+  other-modules:
+    Fedi.TestSpec
+  default-extensions:
+    BlockArguments
+    LambdaCase
+    OverloadedRecordDot
+    OverloadedStrings
+    QuasiQuotes
+    ViewPatterns
+    DuplicateRecordFields
+    NoFieldSelectors
+  build-depends:
+      base
+    , hspec
+    , hspec-discover
+    , hspec-wai
+    , req
+    , aeson
+    , text
+    , raw-strings-qq
+    , pretty-simple
+    , fedi
+  ghc-options:
+    -threaded -rtsopts -with-rtsopts=-N
+  build-tool-depends:
+      hspec-discover:hspec-discover
+  default-language: GHC2021

src/Fedi.hs

@@ -4,6 +4,8 @@ import Fedi.Crypto as Export
 import Fedi.Helpers as Export
 import Fedi.Requests as Export
 import Fedi.Routes as Export
+import Fedi.Signature.Check as Export
+import Fedi.Signature.Sign as Export
 import Fedi.Types as Export
 import Fedi.Types.Helpers as Export
 import Fedi.UserDetails as Export

src/Fedi/Crypto.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DataKinds #-}
 
 module Fedi.Crypto where
 
@@ -12,6 +12,7 @@ import Data.Base64.Types qualified as Base64
 import Data.ByteArray qualified as BA
 import Data.ByteString.Base64 qualified as Base64
 import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
 import Data.X509 qualified as Crypto
 import Fedi.Helpers
 
@@ -31,7 +32,7 @@ verifyPub pubkeypem sig message = do
       _ -> throw "failed to read pubkey pem"
   pure $ Crypto.verify (Just Crypto.SHA256) pubkey message (decodeBase64 sig)
 
-sign :: FilePath -> ByteString -> IO Signed
+sign :: FilePath -> ByteString -> IO SignedMessage
 sign privatePemFile message = do
   -- get private key
   privkeypem <- Crypto.readKeyFile privatePemFile
@@ -45,21 +46,23 @@ sign privatePemFile message = do
       & either (throw . show) pure
 
   -- return
-  pure Signed {..}
+  pure (makeSignedMessage signedMessage)
 
-newtype Signed
-  = Signed
-  { signedMessage :: ByteString
-  }
+-- | A Base64 encoded string.
+newtype SignedMessage
+  = SignedMessage (Base64.Base64 'Base64.StdPadded ByteString)
   deriving (Show)
 
-ppSigned :: Signed -> String
-ppSigned signed =
-  unlines
-    [ "Signature"
-    , "{ signedMessage = " <> encodeBase64String signed.signedMessage
-    , "}"
-    ]
+makeSignedMessage :: ByteString -> SignedMessage
+makeSignedMessage = SignedMessage . Base64.encodeBase64'
+
+ppSignedMessage :: SignedMessage -> String
+ppSignedMessage (SignedMessage message) =
+  T.unpack $ T.decodeUtf8 $ Base64.extractBase64 message
+
+bsSignedMessage :: SignedMessage -> ByteString
+bsSignedMessage (SignedMessage message) =
+  Base64.extractBase64 message
 
 encodeBase64 :: ByteString -> ByteString
 encodeBase64 = Base64.extractBase64 . Base64.encodeBase64'

src/Fedi/Helpers.hs

@@ -9,7 +9,7 @@ import Data.Aeson qualified as A
 import Data.Aeson.Encode.Pretty qualified as AP
 import Data.ByteString as Export (ByteString)
 import Data.Foldable as Export
-import Data.Function as Export
+import Data.Function as Export hiding (id)
 import Data.Functor as Export
 import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
 import Data.String as Export (fromString)
@@ -18,7 +18,6 @@ import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TL
 import Data.Time as Export (UTCTime)
 import Data.Traversable as Export
-import Fedi.UserDetails
 import GHC.Generics as Export (Generic)
 import Text.Pretty.Simple qualified as PS
 

src/Fedi/Routes.hs

@@ -3,6 +3,7 @@ module Fedi.Routes (
   module Export,
 ) where
 
+import Fedi.Helpers
 import Fedi.Routes.Follow as Export
 import Fedi.Routes.Helpers as Export
 import Fedi.Routes.Inbox as Export

src/Fedi/Routes/Notes.hs

@@ -1,6 +1,7 @@
 module Fedi.Routes.Notes where
 
 import Data.Aeson qualified as A
+import Fedi.Helpers
 import Fedi.Routes.Helpers
 import Fedi.Types
 import Fedi.UserDetails

src/Fedi/Signature/Check.hs

@@ -19,6 +19,7 @@ import Fedi.Routes.Helpers
 import Fedi.Signature.Types
 import Fedi.Types
 import Fedi.UserDetails
+import Network.HTTP.Types.Header qualified as HTTP
 import Network.HTTP.Types.URI qualified as HTTP
 import Network.Wai qualified as Wai
 import Text.ParserCombinators.ReadP qualified as P
@@ -45,7 +46,7 @@ checkSignatureAndParseBody = do
     personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
 
   signatureString <-
-    makeSignatureString request sigheader.headers
+    signatureStringFromRequest request sigheader.headers
 
   -- check
   liftIO $
@@ -54,9 +55,11 @@ checkSignatureAndParseBody = do
   -- parse the body and return it
   parseJson body
 
-makeSignatureString
-  :: forall m. (MonadThrow m) => Wai.Request -> [T.Text] -> m ByteString
-makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
+signatureStringFromRequest
+  :: forall m
+   . (MonadThrow m)
+  => Wai.Request -> [T.Text] -> m ByteString
+signatureStringFromRequest request (map (T.encodeUtf8 . T.toLower) -> headers) = do
   let
     requestHeaders = Wai.requestHeaders request
     method = T.encodeUtf8 $ T.toLower $ T.decodeUtf8 $ Wai.requestMethod request
@@ -65,6 +68,13 @@ makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
         <> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
         <> HTTP.renderQuery True (Wai.queryString request)
     requestTarget = method <> " " <> path
+  signatureStringFromSpecifics requestHeaders requestTarget headers
+
+signatureStringFromSpecifics
+  :: forall m
+   . (MonadThrow m)
+  => HTTP.RequestHeaders -> ByteString -> [ByteString] -> m ByteString
+signatureStringFromSpecifics requestHeaders requestTarget headers = do
   let
     mylookup :: ByteString -> m ByteString
     mylookup header
@@ -88,7 +98,6 @@ makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
           case result of
             Nothing -> throw $ "Missing header '" <> show header <> "'."
             Just value -> pure $ header <> ": " <> value
-
   BS.intercalate "\n" <$> traverse mylookup headers
 
 checkSignature

src/Fedi/Signature/Sign.hs

@@ -21,22 +21,16 @@ signSignature details host requestTarget body = do
   date <-
     Time.getCurrentTime
       <&> Time.formatTime Time.defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
-
   let
     digest = "SHA-256=" <> encodeBase64 (makeDigest body)
     keyId = actorUrl details <> "#main-key"
     headers = ["(request-target)", "host", "date", "digest"]
     components = []
     signatureString = makeSignatureString host requestTarget date digest
-
-  -- BS.putStr $ signatureString <> "\n"
-
   signed <- sign details.privatePem signatureString
-
   let
-    signature = encodeBase64 signed.signedMessage
+    signature = bsSignedMessage signed
     signatureHeader = SignatureHeader {..}
-
   pure HttpSignature {..}
 
 makeSignatureString

src/Fedi/Signature/Types.hs

@@ -5,6 +5,7 @@ module Fedi.Signature.Types where
 import Data.ByteString qualified as BS
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
+import Fedi.Helpers
 import Fedi.UserDetails
 import Prelude hiding (error)
 

src/Fedi/Types.hs

@@ -2,10 +2,10 @@
 
 module Fedi.Types where
 
-import Control.Monad (guard)
 import Data.Aeson qualified as A
 import Data.Aeson.Types qualified as A
 import Data.Text qualified as T
+import Fedi.Helpers
 import Fedi.UserDetails
 import Prelude hiding (id, last)
 

src/Fedi/UserDetails.hs

@@ -1,19 +1,11 @@
 module Fedi.UserDetails (
   module Fedi.UserDetails,
-  module Export,
 ) where
 
 import Data.Aeson qualified as A
-import Data.ByteString as Export (ByteString)
-import Data.Foldable as Export
-import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
-import Data.String as Export (fromString)
-import Data.Text as Export (Text)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
-import Data.Time as Export (UTCTime)
-import Data.Traversable as Export
-import GHC.Generics as Export (Generic)
+import Fedi.Helpers
 
 type Url = String
 
@@ -50,3 +42,8 @@ actorUrl details =
 
 fullmention :: UserDetails -> String
 fullmention details = "@" <> details.username <> "@" <> details.domain
+
+readUserDetailsFile :: FilePath -> IO UserDetails
+readUserDetailsFile detailsFile =
+  A.eitherDecodeFileStrict detailsFile
+    <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id

src/Fedi/Webfinger.hs

@@ -1,6 +1,7 @@
 module Fedi.Webfinger where
 
 import Data.Aeson qualified as A
+import Fedi.Helpers
 import Fedi.UserDetails
 
 data Webfinger

test/Fedi/TestSpec.hs

@@ -0,0 +1,37 @@
+module Fedi.TestSpec where
+
+import Control.Monad.IO.Class
+import Data.Aeson qualified as A
+import Fedi qualified
+import Test.Hspec
+
+-- * Tests
+
+spec :: Spec
+spec = do
+  describe "Fedi" do
+    httpSignature
+
+httpSignature :: Spec
+httpSignature = do
+  describe "HTTP Signature" do
+    describe "Sign" do
+      it "Sign a simple message" do
+        details <- readDetails
+        signed <- Fedi.sign details.privatePem "hello world"
+        shouldBe
+          (Fedi.ppSignedMessage signed)
+          "rXu4VgqPA5izfSSznnuHVk68gFqjLmn2gM85LqNsyXgRhk1V6WnLCtSaMR3ZaqefaU37D1Nj2xUnPu6x54HqkW99Iwe64HAddKFdMNtkcyh523+FF9t8CuRcT7l97RfbqcZSkH6D7eF8+eDa/ItpP+uwdGBDzlk8gkgRwXMP63cLVd9gboNOqvFXx11OZLBWHHMCkJuKDbzuu+46fkPXDKnDojuDLLrfd9cWqee3w3qkvigZ2T/2s3iiXrvt4rOb5Gi0oLmXh6/mqDHBIDinkyXb72vEP/HhzZMv+OSa/6tZ+F1DWf9RYlh0tItfnU4qIamRusr/YYC3KDQJzkzPZQ=="
+      it "Verify a simple message" do
+        details <- readDetails
+        let
+          signedMessage =
+            "rXu4VgqPA5izfSSznnuHVk68gFqjLmn2gM85LqNsyXgRhk1V6WnLCtSaMR3ZaqefaU37D1Nj2xUnPu6x54HqkW99Iwe64HAddKFdMNtkcyh523+FF9t8CuRcT7l97RfbqcZSkH6D7eF8+eDa/ItpP+uwdGBDzlk8gkgRwXMP63cLVd9gboNOqvFXx11OZLBWHHMCkJuKDbzuu+46fkPXDKnDojuDLLrfd9cWqee3w3qkvigZ2T/2s3iiXrvt4rOb5Gi0oLmXh6/mqDHBIDinkyXb72vEP/HhzZMv+OSa/6tZ+F1DWf9RYlh0tItfnU4qIamRusr/YYC3KDQJzkzPZQ=="
+          message = "hello world"
+        result <- Fedi.verifyPub (Fedi.pemToBS details.publicPem) signedMessage message
+        shouldBe
+          result
+          True
+
+readDetails :: IO Fedi.UserDetails
+readDetails = Fedi.readUserDetailsFile "test/public/details.json"

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

test/public/details.json

@@ -0,0 +1,10 @@
+{
+  "domain": "fediserve.example.com",
+  "username": "me",
+  "name": "me",
+  "icon": "https://fedi.example.com/images/icon.png",
+  "image": "https://fedi.example.com/images/image.png",
+  "summary": "my summary",
+  "publicPem": "-----BEGIN PUBLIC KEY-----\nMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAslpzUw8zmQKvQwyyn4H/\n93/KQhUGDXRclE+J7m7gC8PRJZj884uWHjWOdtMdWq2Ec7ZMNzKldjj9MxLulv6p\n+HrEPWFmMpGFVDvNLvgawzt6M8Ygo2yoY2yeUtnLKqJF/vibBr51B75zp9qCNzP4\nMpdwpgppz5uyS28xSt5BWo5SsJ7Cq8H4jvl+qkDHpV/TeLdYDv7nI6zmnvbgsWdh\n9kNJEr9zByvAOMGGyxTWLl0tNTBGxbj0N6js7zac69KKlbUXGSmiGec6ITX7ujr+\n9XbX/KNw1nShi+zHvpUoeSNcY6xGfn0NNmE6PaEHimUeGXB/mkmbZaVcxPP+/vNI\nAQIDAQAB\n-----END PUBLIC KEY-----",
+  "privatePem": "test/public/private.pem"
+}

test/public/private.pem

@@ -0,0 +1,28 @@
+-----BEGIN PRIVATE KEY-----
+MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQCyWnNTDzOZAq9D
+DLKfgf/3f8pCFQYNdFyUT4nubuALw9ElmPzzi5YeNY520x1arYRztkw3MqV2OP0z
+Eu6W/qn4esQ9YWYykYVUO80u+BrDO3ozxiCjbKhjbJ5S2csqokX++JsGvnUHvnOn
+2oI3M/gyl3CmCmnPm7JLbzFK3kFajlKwnsKrwfiO+X6qQMelX9N4t1gO/ucjrOae
+9uCxZ2H2Q0kSv3MHK8A4wYbLFNYuXS01MEbFuPQ3qOzvNpzr0oqVtRcZKaIZ5zoh
+Nfu6Ov71dtf8o3DWdKGL7Me+lSh5I1xjrEZ+fQ02YTo9oQeKZR4ZcH+aSZtlpVzE
+8/7+80gBAgMBAAECggEASLyRrsySzvKk1nPtvxaN9PqFWpjnXIJZpVSg3IAUWEf2
+Wl5/vrVtNgnCfZxQquP8EhLFF3fMuh+4x2UPr73RRNiQgrXfr3zggr9WyTJ++6Mc
+jdPeCLguHko0cXaIIG2InVj3JHN1GADoewqms2u666sOUnEJwRTuzEvfLvjgb1TO
+MbF7E72CQCO4v+2naH1JLZZC7yCI1GZehDzkRGrsX7DSwysJOBbp81FZvpvRvQGF
+oUJImVJSyICB97qOwM5kB3G5Y6auzAOUXpznWrF/cZiMqcQx2WkVohUr6eMt09rJ
+qz15pq7aq+qRAuUyoKCi6ZWmnnG+JSFzu1J6fw6gfwKBgQD7f8YM/eguzq2WvGua
+AhE1XGpEo10EgNg6g6RHhZlf5VITykxG7iBZUX2srij1+pHMKIFgUPWOPXDpjf2z
+MD1O5SVcJOdRdeWyG4uddLjBckh/fUm9KS2a1+FCMS7Kf5RSMCPdAsmAEu+Sfgzw
+O0H7KSHS4lTk7uoiQtdUz9qDRwKBgQC1i5B1iDje10A1EyZuaKYOEOOoljoI3PL1
+jkVaCKVzjnxl9FdfbQnyGbSa+p8VndYhF/Kr+cfTxf72FAghtXEk7v+9H/G9Q7pE
+J4Ci9dWWiR/VEpi+f8liZyTXcK8GXjM2wjKxhNpuMFkmd7dmkyT18rERrlJVYYFY
+JSxU4qqudwKBgHa2pm7Ff05w4oGPaR8mMKdGeybxEdwpUWe1cdsM1gvs/CQ5Tm4A
+wyZGEBNtlgod/6olyIQFUxOULvMfwgxODfJquYrYJJRQGV9MH0fwq7EsV8pOAnuW
+r18y3bJX8uVE+WceMB+HzEN3LLyyYTsYTZnXnY6kpTv3Bm+rq2buQg/LAoGBAI5T
+ax5pfERftkulxsRaMIzoesJpe/gE2Ejgj8hE7QkKFMaNZ449WsW9l1TE1MFKq1vo
+fWyL9zg0imz7SWC78YcGA+KOT6OUnEvgOD4Jwrgwqo8N9EeswQHvYPextNWmNjpg
+xwNa5y/poYrB4jt9ckWLTXxSEOQ0/AVRp06pISyDAoGBAJGyZp4OsPpBDBka+cN7
+MbuPyEmRuH85Ust3ckBo2W3eWAQE+tyz6GtYbu/Lk+8WFNipOG4dIeGKt8EqlQcY
+PM8LSGkgFqvCzXyFgCm0bjFUDez7zkhTCdOtGR7rS8SmPciVuA3HwQd3AiToE9Cb
+gpBp7jigV5icO3byxWBSr++j
+-----END PRIVATE KEY-----

test/public/public.pem

@@ -0,0 +1,9 @@
+-----BEGIN PUBLIC KEY-----
+MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAslpzUw8zmQKvQwyyn4H/
+93/KQhUGDXRclE+J7m7gC8PRJZj884uWHjWOdtMdWq2Ec7ZMNzKldjj9MxLulv6p
++HrEPWFmMpGFVDvNLvgawzt6M8Ygo2yoY2yeUtnLKqJF/vibBr51B75zp9qCNzP4
+Mpdwpgppz5uyS28xSt5BWo5SsJ7Cq8H4jvl+qkDHpV/TeLdYDv7nI6zmnvbgsWdh
+9kNJEr9zByvAOMGGyxTWLl0tNTBGxbj0N6js7zac69KKlbUXGSmiGec6ITX7ujr+
+9XbX/KNw1nShi+zHvpUoeSNcY6xGfn0NNmE6PaEHimUeGXB/mkmbZaVcxPP+/vNI
+AQIDAQAB
+-----END PUBLIC KEY-----