changed order of type arguments of Auth; small improvements

src/Data/Auth.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE DataKinds  #-}
+{-# LANGUAGE RankNTypes #-}
+
 {-# OPTIONS_HADDOCK show-extensions #-}
 
 {-|
@@ -23,6 +26,9 @@ module Data.Auth
     , AuthError (..)
     , serialize
     , deserialize
+    , toProver
+    , toVerifier
+    , toVerifier'
     , module Data.Auth.Hash
     , module Data.Auth.Monad
     ) where
@@ -34,3 +40,23 @@ import Data.Auth.Core
 import Data.Auth.Hash
 import Data.Auth.Monad
 import Data.Auth.Serialize
+
+-- | Extracts the value from a monadic prover-mode computation.
+toProver :: AuthM 'P a -> a
+toProver = fst . runProver
+
+-- | Extracts the value on verifier-side from a monadic prover-mode computation.
+toVerifier :: ( Serializable (f 'P)
+              , Deserializable (f 'V)
+              )
+           => AuthM 'P (f 'P)
+           -> f 'V
+toVerifier = unsafeDeserialize . serialize . toProver
+
+-- | Version of 'toVerifier' for 'Auth' values.
+toVerifier' :: ( Serializable (f 'P)
+              , Deserializable (f 'V)
+              )
+            => AuthM 'P (Auth (f 'P) 'P)
+            -> Auth (f 'V) 'V
+toVerifier' = unsafeDeserialize . serialize . toProver

src/Data/Auth/Core.hs

@@ -41,37 +41,37 @@ data Mode = P | V deriving (Show, Eq, Ord)
 -- | Authenticated version of type @a@.
 -- For the /prover/, this is just an @a@,
 -- but for the /verifier/, it is the `Hash` of that @a@.
-data Auth :: Mode -> Type -> Type where
-    AuthP :: a -> Auth 'P a
-    AuthV :: Hash -> Auth 'V a
+data Auth :: Type -> Mode -> Type where
+    AuthP :: a -> Auth a 'P
+    AuthV :: Hash -> Auth a 'V
 
-deriving instance Show a => Show (Auth m a)
-deriving instance Eq a => Eq (Auth m a)
-deriving instance Ord a => Ord (Auth m a)
+deriving instance Show a => Show (Auth a m)
+deriving instance Eq a => Eq (Auth a i)
+deriving instance Ord a => Ord (Auth a i)
 
-instance Serializable a => Serializable (Auth 'P a) where
+instance Serializable a => Serializable (Auth a 'P) where
     put (AuthP a) = put $ hash a
 
-instance Serializable (Auth 'V a) where
+instance Serializable (Auth a 'V) where
     put (AuthV h) = put h
 
-instance Deserializable a => Deserializable (Auth 'P a) where
+instance Deserializable a => Deserializable (Auth a 'P) where
     get = AuthP <$> get
 
-instance Deserializable (Auth 'V a) where
+instance Deserializable (Auth a 'V) where
     get = AuthV <$> get
 
 -- | Used by the /prover/ to construct an @`Auth` a@.
-authP :: a -> Auth 'P a
+authP :: a -> Auth a 'P
 authP = AuthP
 
 -- | Used by the /verifier/ to construct an @`Auth` a@.
-authV :: Serializable a => a -> Auth 'V a
+authV :: Serializable a => a -> Auth a 'V
 authV = AuthV . hash
 
 -- | Used by the /prover/ to deconstruct an @`Auth` a@ and a
 -- /certificate stream/ for consumption by the 7verifier/.
-unauthP :: Serializable a => Auth 'P a -> (a, ByteString)
+unauthP :: Serializable a => Auth a 'P -> (a, ByteString)
 unauthP (AuthP a) = (a, serialize a)
 
 -- | Enumerates potential authentication errors.
@@ -87,7 +87,7 @@ instance Exception AuthError
 -- provided by the /prover/. This either succeeds with an @a@ and the rest of
 -- the stream or fails with an @`AuthError`@.
 unauthV :: (Serializable a, Deserializable a)
-        => Auth 'V a  -- ^ the value to deconstruct
+        => Auth a 'V  -- ^ the value to deconstruct
         -> ByteString -- ^ certificate stream provided by the prover
         -> Either AuthError (a, ByteString)
 unauthV (AuthV h) bs = case deserialize bs of

src/Data/Auth/Monad.hs

@@ -71,13 +71,12 @@ import           Data.Monoid                    (mempty, (<>))
 import           Pipes                          (ListT)
 
 import           Data.Auth.Core
-import           Data.Auth.Hash
 import           Data.Auth.Serialize
 
 -- | Functor describing the special operations.
 data AuthF :: Mode -> Type -> Type where
-    A :: Serializable a => a -> (Auth i a -> b) -> AuthF i b
-    U :: (Serializable a, Deserializable a) => Auth i a -> (a -> b) -> AuthF i b
+    A :: Serializable a => a -> (Auth a i -> b) -> AuthF i b
+    U :: (Serializable a, Deserializable a) => Auth a i -> (a -> b) -> AuthF i b
 
 deriving instance Functor (AuthF m)
 
@@ -98,26 +97,26 @@ type AuthM i = AuthT i Identity
 -- authenticated data structures.
 class Monad m => MonadAuth i m | m -> i where
 
-    auth :: Serializable a => a -> m (Auth i a)
+    auth :: Serializable a => a -> m (Auth a i)
 
     default auth :: ( MonadTrans t
                     , MonadAuth i n
                     , t n ~ m
                     , Serializable a
                     )
                  => a
-                 -> m (Auth i a)
+                 -> m (Auth a i)
     auth = lift . auth
 
-    unauth :: (Serializable a, Deserializable a) => Auth i a -> m a
+    unauth :: (Serializable a, Deserializable a) => Auth a i -> m a
 
     default unauth :: ( MonadTrans t
                       , MonadAuth i n
                       , t n ~ m
                       , Serializable a
                       , Deserializable a
                       )
-                   => Auth i a
+                   => Auth a i
                    -> m a
     unauth = lift . unauth
 
@@ -240,12 +239,3 @@ runVerifierT m bs =
 -- Left AuthenticationError
 runVerifier :: AuthM 'V b -> ByteString -> Either AuthError b
 runVerifier m = runIdentity . runVerifierT m
-
--- | Interprets a function @'Auth' a -> 'AuthM' b@ in verifier-mode
--- by simply taking the proof-string as an additional argument,
--- given the hash corresponding to an @'Auth' a@ argument.
-runVerifier' :: (Auth 'V a -> AuthM 'V b)
-             -> Hash
-             -> ByteString
-             -> Either AuthError b
-runVerifier' f h = runVerifier (f $ AuthV h)

src/Data/Auth/Serialize.hs

@@ -26,6 +26,7 @@ module Data.Auth.Serialize
     , GDeserializable (..)
     , serialize
     , deserialize
+    , unsafeDeserialize
     ) where
 
 import qualified Data.Binary          as B
@@ -150,3 +151,18 @@ instance Deserializable Word8 where
 deriving instance Deserializable Bool
 deriving instance Deserializable a => Deserializable [a]
 deriving instance (Deserializable a, Deserializable b) => Deserializable (a, b)
+
+-- | Unsafe version of 'deserialize' which can fail and ignores unconsumed
+-- input.
+--
+-- >>> unsafeDeserialize (serialize False) :: Bool
+-- False
+--
+-- >>> unsafeDeserialize (serialize False) :: Int
+-- *** Exception: not enough bytes
+-- ...
+--
+unsafeDeserialize :: Deserializable a => ByteString -> a
+unsafeDeserialize bs = case deserialize bs of
+    Left e       -> error e
+    Right (_, x) -> x

src/Examples/List.hs

@@ -33,8 +33,7 @@ module Examples.List
 
 import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Char8  as B8
-import           Data.ByteString.Lazy   (ByteString, empty, fromStrict,
-                                         toStrict)
+import           Data.ByteString.Lazy   (ByteString, fromStrict, toStrict)
 import           Network
 import           System.IO              (BufferMode (..), Handle, hGetLine,
                                          hPrint, hPutStrLn, hSetBuffering)
@@ -45,19 +44,19 @@ import           Data.Auth
 infixr 5 :>
 
 -- | An authenticated list.
-data List i a = Nil | a :> Auth i (List i a)
+data List a i = Nil | a :> Auth (List a i) i
     deriving (Show, Generic)
 
-deriving instance Serializable a => Serializable (List 'P a)
-deriving instance Serializable a => Serializable (List 'V a)
-deriving instance Deserializable a => Deserializable (List 'P a)
-deriving instance Deserializable a => Deserializable (List 'V a)
+deriving instance Serializable a => Serializable (List a 'P)
+deriving instance Serializable a => Serializable (List a 'V)
+deriving instance Deserializable a => Deserializable (List a 'P)
+deriving instance Deserializable a => Deserializable (List a 'V)
 
 -- | Converts a standard list into an authenticated list.
 --
 -- >>> fst $ runProver $ fromList "Haskell"
 -- 'H' :> AuthP ('a' :> AuthP ('s' :> AuthP ('k' :> AuthP ('e' :> AuthP ('l' :> AuthP ('l' :> AuthP Nil))))))
-fromList :: (MonadAuth i m, Serializable (List i a)) => [a] -> m (List i a)
+fromList :: (MonadAuth i m, Serializable (List a i)) => [a] -> m (List a i)
 fromList = foldr f $ return Nil
   where
     f x m = (x :>) <$> (m >>= auth)
@@ -69,12 +68,12 @@ data Result = RPush | RPop (Maybe Int)
     deriving (Show, Read, Eq, Ord)
 
 executeCommand :: ( MonadAuth i m
-                  , Serializable (List i Int)
-                  , Deserializable (List i Int)
+                  , Serializable (List Int i)
+                  , Deserializable (List Int i)
                   )
                => Command
-               -> Auth i (List i Int)
-               -> m (Result, Auth i (List i Int))
+               -> Auth (List Int i) i
+               -> m (Result, Auth (List Int i) i)
 executeCommand (Push n) a = (RPush,) <$> auth (n :> a)
 executeCommand Pop      a = do
     l <- unauth a
@@ -84,8 +83,8 @@ executeCommand Pop      a = do
 
 executeCommandLying :: MonadAuth 'P m
                     => Command
-                    -> Auth 'P (List 'P Int)
-                    -> m (Result, Auth 'P (List 'P Int))
+                    -> Auth (List Int 'P) 'P
+                    -> m (Result, Auth (List Int 'P) 'P)
 executeCommandLying (Push 42) a = executeCommand (Push 43) a
 executeCommandLying c         a = executeCommand c a
 
@@ -100,13 +99,9 @@ proverIO lie port = do
     (h, _, _) <- accept s
     hSetBuffering h LineBuffering
     putStrLn "accepted verifier connection"
-    go h nilP
+    go h $ toProver nil
   where
-
-    nilP :: Auth 'P (List 'P Int)
-    nilP = fst $ runProver $ auth Nil
-
-    go :: Handle -> Auth 'P (List 'P Int) -> IO ()
+    go :: Handle -> Auth (List Int 'P) 'P -> IO ()
     go h s = do
         putStrLn $ "STATE: " ++ show s
         c <- read <$> hGetLine h
@@ -127,13 +122,9 @@ verifierIO port = do
     h <- connectTo "127.0.0.1" $ PortNumber port
     hSetBuffering h LineBuffering
     putStrLn $ "connected to prover on port " ++ show port
-    go h nilV
+    go h $ toVerifier' nil
   where
-
-    nilV :: Auth 'V (List 'V Int)
-    nilV = let Right x = runVerifier (auth Nil) empty in x
-
-    go :: Handle -> Auth 'V (List 'V Int) -> IO ()
+    go :: Handle -> Auth (List Int 'V) 'V -> IO ()
     go h s = do
         putStrLn $ "STATE: " ++ show s
         putStrLn "enter command!"
@@ -150,6 +141,9 @@ verifierIO port = do
                     Left err       -> putStrLn $ "ERROR: " ++ show err
                     Right (res, t) -> putStrLn ("RESULT: " ++ show res) >> go h t
 
+nil :: AuthM 'P (Auth (List Int 'P) 'P)
+nil = auth Nil
+
 toHex :: ByteString -> String
 toHex = B8.unpack . B16.encode . toStrict
 

src/Examples/Tree.hs

@@ -34,15 +34,15 @@ import Control.Monad.State
 import Data.Auth
 
 -- | A simple authenticated binary tree type.
-data Tree i a =
+data Tree a i =
       Tip a
-    | Node (Auth i (Tree i a)) (Auth i (Tree i a))
+    | Node (Auth (Tree a i) i) (Auth (Tree a i) i)
     deriving (Show, Generic)
 
-deriving instance Serializable a => Serializable (Tree 'P a)
-deriving instance Serializable a => Serializable (Tree 'V a)
-deriving instance Deserializable a => Deserializable (Tree 'P a)
-deriving instance Deserializable a => Deserializable (Tree 'V a)
+deriving instance Serializable a => Serializable (Tree a 'P)
+deriving instance Serializable a => Serializable (Tree a 'V)
+deriving instance Deserializable a => Deserializable (Tree a 'P)
+deriving instance Deserializable a => Deserializable (Tree a 'V)
 
 -- | Describes a direction (@'L'@eft or @'R'@ight), so that
 -- a list of directions gives a path from the root of a @'Tree'@
@@ -51,13 +51,13 @@ data Direction = L | R deriving (Show, Read, Eq, Ord)
 
 -- | Builds a full @'Tree'@ with specified depth and specified tips.
 -- Using a negative depth or providing too few tips causes an error.
-buildTree :: forall i a. Serializable (Tree i a)
+buildTree :: forall i a. Serializable (Tree a i)
           => Int
           -> [a]
-          -> AuthM i (Auth i (Tree i a))
+          -> AuthM i (Auth (Tree a i) i)
 buildTree = evalStateT . go
   where
-    go :: Int -> StateT [a] (AuthM i) (Auth i (Tree i a))
+    go :: Int -> StateT [a] (AuthM i) (Auth (Tree a i) i)
     go 0 = do
         xs <- get
         case xs of
@@ -75,9 +75,9 @@ buildTree = evalStateT . go
 --
 -- >>> fst $ runProver $ buildTree 1 ["Alice", "Bob"] >>= lookupTree [L]
 -- Just "Alice"
-lookupTree :: (Serializable (Tree i a), Deserializable (Tree i a))
+lookupTree :: (Serializable (Tree a i), Deserializable (Tree a i))
            => [Direction]
-           -> Auth i (Tree i a)
+           -> Auth (Tree a i) i
            -> AuthM i (Maybe a)
 lookupTree xs at = do
     t <- unauth at
@@ -97,7 +97,7 @@ lookupTree xs at = do
 -- >>> runVerifier (lookupTree [L, L, R] exampleTreeV) bs
 -- Right (Just "Bob")
 --
-exampleTree :: Serializable (Tree i String) => AuthM i (Auth i (Tree i String))
+exampleTree :: Serializable (Tree String i) => AuthM i (Auth (Tree String i) i)
 exampleTree = buildTree 3 [ "Alice"
                           , "Bob"
                           , "Charlie"
@@ -109,12 +109,9 @@ exampleTree = buildTree 3 [ "Alice"
                           ]
 
 -- | Authenticated example tree (prover version).
-exampleTreeP :: Auth 'P (Tree 'P String)
-exampleTreeP = fst $ runProver exampleTree
+exampleTreeP :: Auth (Tree String 'P) 'P
+exampleTreeP = toProver exampleTree
 
 -- | Authenticated example tree (verifier version)
-exampleTreeV :: Auth 'V (Tree 'V String)
-exampleTreeV =
-    let bs      = snd $ runProver exampleTree
-        Right a = runVerifier exampleTree bs
-    in  a
+exampleTreeV :: Auth (Tree String 'V) 'V
+exampleTreeV = toVerifier' exampleTree