~jonn/do-auth

e9acaf7c2d98b8aea72680b08c70b0f86572d687 — Jonn 1 year, 12 days ago fd3ce24
Problem: Need B64 to send signed challenge back

Solution:

 - Abstract away b64encode/decode for To/FromJSON instances
	(DoAuth.Json)
 - Specify the API a little bit more for DoAuth.Server
 - Add test to figure out what should be the logic of signing a
	challenge

Up next:

 - Implement To/FromJSON instance for Signature
M do-auth.cabal => do-auth.cabal +5 -1
@@ 4,7 4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 4a52f0edacfc0c2454fdc593c89cdcd2d809a3d8c9a6dcdc2cdf061665e0281d
-- hash: 5fa83af348da57b309d81d2467aac055b590507c477db1c527e3536292ceef88

name:           do-auth
version:        0.1.0.0


@@ 31,6 31,7 @@ library
      DoAuth.Crypto.Client
      DoAuth.Crypto.Protocols
      DoAuth.Crypto.Server
      DoAuth.Json
      DoAuth.Server
      Lib
  other-modules:


@@ 51,6 52,7 @@ library
    , servant
    , servant-client
    , servant-server
    , text
    , utf8-string
    , warp
  default-language: Haskell2010


@@ 77,6 79,7 @@ executable do-auth-exe
    , servant
    , servant-client
    , servant-server
    , text
    , utf8-string
    , warp
  default-language: Haskell2010


@@ 112,6 115,7 @@ test-suite test
    , tasty
    , tasty-hedgehog
    , tasty-hunit
    , text
    , utf8-string
    , warp
  default-language: Haskell2010

M package.yaml => package.yaml +1 -0
@@ 35,6 35,7 @@ dependencies:
- base64-bytestring
- utf8-string
- hedgehog
- text

library:
  source-dirs: src

M src/DoAuth/Crypto.hs => src/DoAuth/Crypto.hs +4 -1
@@ 1,10 1,11 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | Super-high-level cryptography needed for our DID-inspired implementation.
module DoAuth.Crypto
  ( PKC (..),
    -- | For testing purposes
    deriveKeypair,
    dummyPkc,
    -- | Need to export DummySigned for testing purposes, since it's impossible
    -- to create an invalid signature with just dummyPkc.


@@ 195,6 196,8 @@ data Signature pk = Signature
  { dacs_pk :: pk,
    dacs_sig :: Sign.Signature ByteString
  }
  deriving (Show, Eq)


-- | Create a detached signature given `PublicKey` and `SecretKey`
sodiumSign ::

M src/DoAuth/Crypto/Server.hs => src/DoAuth/Crypto/Server.hs +3 -13
@@ 21,26 21,16 @@ import qualified Data.ByteString.UTF8 as Bsu
import Data.Either (fromRight)
import Debug.Trace (trace)
import GHC.Generics (Generic)
import DoAuth.Json (b64decode, b64encode)

newtype Challenge = Challenge {getChallenge :: ByteString}
  deriving (Show, Eq)

instance ToJSON Challenge where
  toJSON (Challenge x) =
    object
      [ "__HASKELL_MANUAL_ENCODING__.DoAuth.Crypto.Server.Challenge"
          .= (Bsu.toString . B64.encode) x
      ]
  toJSON (Challenge x) = b64encode "DoAuth.Crypto.Server.Challenge" x

instance FromJSON Challenge where
  parseJSON = withObject "_" $ \obj -> do
    (x :: String) <-
      obj .: "__HASKELL_MANUAL_ENCODING__.DoAuth.Crypto.Server.Challenge"
    pure $
      Challenge $
        fromRight
          (error "Challenge has to be valid Base64")
          ((B64.decode . Bsu.fromString) x)
  parseJSON = b64decode "DoAuth.Crypto.Server.Challenge" Challenge

type SmallChallenge = SizedByteArray 8 ByteString


A src/DoAuth/Json.hs => src/DoAuth/Json.hs +28 -0
@@ 0,0 1,28 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module DoAuth.Json (b64encode, b64decode) 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.Either (fromRight)
import Data.Text (Text)

b64encode :: Text -> Bsu.ByteString -> Value
b64encode label x =
  object
    [ ("__HASKELL_BASE64_ENCODING__." <> label)
        .= (Bsu.toString . B64.encode) x
    ]

b64decode :: Text -> (Bsu.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

M src/DoAuth/Server.hs => src/DoAuth/Server.hs +37 -5
@@ 1,30 1,62 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}

module DoAuth.Server where

import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson
import Data.ByteString (ByteString (..))
import DoAuth.Crypto.Server (Challenge (..), mkChallenge)
import GHC.TypeLits
import Network.Wai.Handler.Warp
import GHC.TypeLits ()
import Network.Wai.Handler.Warp (run)
import Servant
  (Capture,  Post,
    Get,
    JSON,
    Proxy (..),
    Server,
    serve,
    type (:<|>) (..),
    type (:>),
  )
import Data.Text ( Text )

type API =
  "register" :> (RegPhase1API :<|> RegPhase2API)
    :<|> "claim" :> ClaimAPI

type RegPhase1API = "ask" :> Get '[JSON] Challenge
type User = Text

type RegPhase1API = "ask" :> Capture "user" User :> Get '[JSON] (Maybe Challenge)
type RegPhase2API = "tell" :> Get '[JSON] Bool

type ClaimAPI = "thing" :> Get '[JSON] Bool


-- | Ask for a challenge required to get registered as user with name 'user'.
--
-- Returns 'Nothing' (AKA `JS null`) if user is already registered or is pending
-- registration.
--
-- Heads up / TODO
-- Currently, lookupUser is a placeholder that always returns False. Instead it
-- should be an actual function that performs a side effect of reading from VC
-- database.
--
-- Probably, correct architecture here is to have a two-layered system:
--  1. In-memory fixed-size queue of clients pending registration (~Redis)
--  2. Persistent, replicable, optionally append-only storage of known users (~PostgreSQL)
regPhase1Server :: Server RegPhase1API
regPhase1Server = liftIO mkChallenge
regPhase1Server user = do
  hasUser <- lookupUser user
  liftIO $ challengeMaybe hasUser
  where
    challengeMaybe False = Just <$> mkChallenge
    challengeMaybe True = pure Nothing
    lookupUser _ = pure False

-- | Process challenge response by a user
regPhase2Server :: Server RegPhase2API
regPhase2Server = pure False


M test/Test/Crypto/Server.hs => test/Test/Crypto/Server.hs +33 -4
@@ 1,3 1,4 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Test.Crypto.Server where


@@ 8,9 9,16 @@ import Data.Aeson.Types (parseEither)
import qualified Data.ByteString as Bs
import Debug.Trace (trace)
import DoAuth.Crypto.Server (Challenge (..), mkChallenge)
import Hedgehog
import Hedgehog (Property, assert, forAll, property, tripping)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Crypto.Key (Params (..))
import Crypto.Key.Internal (DerivationSlip)
import Crypto.Sign (PublicKey)
import Data.ByteArray (ScrubbedBytes)
import Data.ByteString (ByteString)
import DoAuth.Crypto (deriveKeypair, sign, verify)
import NaCl.Sign (SecretKey)

hprop_challenge_is_small :: Property
hprop_challenge_is_small = property $ do


@@ 20,11 28,32 @@ hprop_challenge_is_small = property $ do

hprop_challenge_is_tripping :: Property
hprop_challenge_is_tripping = property $ do
  chal <- forAll $ Gen.bytes $ Range.singleton 8
  chalBytes <- forAll $ Gen.bytes $ Range.singleton 8
  tripping
    (Challenge chal)
    (Challenge chalBytes)
    toJSON
    fromJSON'
  where
    fromJSON' value =
      parseEither parseJSON value
\ No newline at end of file
      parseEither parseJSON value
hprop_challenge_is_signable :: Property
hprop_challenge_is_signable = property $ do
  (pass :: Bs.ByteString) <- forAll $ Gen.bytes $ Range.linear 8 16
  chalBytes <- forAll $ Gen.bytes $ Range.singleton 8
  let c = Challenge chalBytes
  (Just (pk, sk, _) :: Maybe (PublicKey ByteString, SecretKey ScrubbedBytes, DerivationSlip)) <-
    liftIO $
      deriveKeypair
        -- NEVER USE THESE PARAMS IN ANY REAL CODE
        -- limits are so low to have blazingly quick
        -- proptests.
        ( Params
            { opsLimit = 1,
              memLimit =
                1000000
            }
        )
        pass
  -- Creates detached signature storing 'pk'
  let sigForChalBytes = sign (pk, sk) chalBytes
  assert $ verify sigForChalBytes chalBytes
\ No newline at end of file