3 files changed, 44 insertions(+), 9 deletions(-)

M src/DoAuth/Crypto.hs
M src/DoAuth/Crypto/Server.hs
M src/DoAuth/Json.hs

@@ 1,3 1,6 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 


@@ 25,11 28,14 @@ import Crypto.Key (DerivationSlip, Params (..), derive, rederive)
 import qualified Crypto.Key as Key
 import Crypto.Nonce (generate)
 import Crypto.Sign (PublicKey, SecretKey)
+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:))
 import Data.ByteArray (ByteArray, ByteArrayAccess (copyByteArrayToPtr, withByteArray), ScrubbedBytes)
 import Data.ByteArray.Sized (ByteArrayN)
 import qualified Data.ByteArray.Sized as Sized
 import Data.ByteString (ByteString (..))
+import Data.Maybe (fromJust)
 import Data.Proxy (Proxy (Proxy))
+import DoAuth.Json (b64decode, b64encode, base64StringDecode')
 import GHC.TypeLits (type (<=))
 import qualified Libsodium as Na
 import qualified NaCl.Sign as Sign


@@ 198,6 204,30 @@ data Signature pk = Signature
   }
   deriving (Show, Eq)
 
+instance ToJSON (Signature (PublicKey ByteString)) where
+  toJSON
+    (Signature pk sig) =
+      object $
+        b64encode
+          "DoAuth.Crypto.Signature.dacs_pk"
+          (Sized.unSizedByteArray pk)
+          ++ b64encode
+            "DoAuth.Crypto.Signature.dacs_sig"
+            (Sized.unSizedByteArray sig)
+
+instance FromJSON (Signature (PublicKey ByteString)) where
+  parseJSON = withObject "_" $ \obj -> do
+    (pkStr :: String) <-
+      obj .: "__HASKELL_BASE64_ENCODING__.DoAuth.Crypto.Signature.dacs_pk"
+    (sigStr :: String) <-
+      obj .: "__HASKELL_BASE64_ENCODING__.DoAuth.Crypto.Signature.dacs_sig"
+    return $
+      Signature (strToPk pkStr) (strToSig sigStr)
+    where
+      strToPk pkStr = fromJust $ Sign.toPublicKey (base64StringDecode' pkErr pkStr) :: PublicKey ByteString
+      strToSig sigStr = fromJust $ Sign.toSignature (base64StringDecode' sigErr sigStr)
+      pkErr = "Detached signature has to store a public key in valid Base64 encoding. None was provided."
+      sigErr = "Detached signature has to store the signature body itself in valid Base64 encoding. None was provided."
 
 -- | Create a detached signature given `PublicKey` and `SecretKey`
 sodiumSign ::

@@ 27,7 27,7 @@ newtype Challenge = Challenge {getChallenge :: ByteString}
   deriving (Show, Eq)
 
 instance ToJSON Challenge where
-  toJSON (Challenge x) = b64encode "DoAuth.Crypto.Server.Challenge" x
+  toJSON (Challenge x) = object $ b64encode "DoAuth.Crypto.Server.Challenge" x
 
 instance FromJSON Challenge where
   parseJSON = b64decode "DoAuth.Crypto.Server.Challenge" Challenge

@@ 1,28 1,33 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module DoAuth.Json (b64encode, b64decode) where
+module DoAuth.Json (b64encode, b64decode, base64StringDecode') where
 
 import Data.Aeson (KeyValue ((.=)), Value, object, withObject, (.:))
 import Data.Aeson.Types (Parser)
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.UTF8 as Bsu
+import Data.ByteString (ByteString (..))
 import Data.Either (fromRight)
 import Data.Text (Text)
 
-b64encode :: Text -> Bsu.ByteString -> Value
+-- | Encode a single Key-Value pair with Base64.
+b64encode :: KeyValue a => Text -> ByteString -> [a]
 b64encode label x =
-  object
     [ ("__HASKELL_BASE64_ENCODING__." <> label)
         .= (Bsu.toString . B64.encode) x
     ]
 
-b64decode :: Text -> (Bsu.ByteString -> a) -> Value -> Parser a
+-- | Decodes a single-field Base64 object with the help of a constructor
+--
+-- TODO: Generalise over multi-field records.
+b64decode :: Text -> (ByteString -> a) -> Value -> Parser a
 b64decode label constructor = withObject "_" $ \obj -> do
   (x :: String) <-
     obj .: ("__HASKELL_BASE64_ENCODING__." <> label)
   pure $
-    constructor $
-      fromRight
-        (error "Challenge has to be valid Base64")
-        ((B64.decode . Bsu.fromString) x)>
\ No newline at end of file
+    constructor $ base64StringDecode' "Challenge has to be valid Base64" x
+
+-- | Very dangerous convenience function to decode base64-encoded strings
+base64StringDecode' :: String -> String -> ByteString
+base64StringDecode' msg x = fromRight (error msg) ((B64.decode . Bsu.fromString) x)<
\ No newline at end of file