~jonn/do-auth

c5ec5c21709066bc9d788eefde6419b597c95225 — Jonn 10 months ago e9acaf7
Problem: can't send detached signatures around

Solution:

 - Add instances for JSON serialisation for Signature type
 - Reuse DoAuth.Json as much as possible, but write a hacky FromJSON
	instance. (TODO Generalise DoAuth.Json)

Next up:

 - Write tripping tests for this serialisation
 - Use this serialisation to encode Post request body in phase 2 of
	registration
3 files changed, 44 insertions(+), 9 deletions(-)

M src/DoAuth/Crypto.hs
M src/DoAuth/Crypto/Server.hs
M src/DoAuth/Json.hs
M src/DoAuth/Crypto.hs => src/DoAuth/Crypto.hs +30 -0
@@ 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 ::

M src/DoAuth/Crypto/Server.hs => src/DoAuth/Crypto/Server.hs +1 -1
@@ 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

M src/DoAuth/Json.hs => src/DoAuth/Json.hs +13 -8
@@ 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