-- |
-- Module      :  Cryptol.ModuleSystem.Fingerprint
-- Copyright   :  (c) 2019 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

module Cryptol.ModuleSystem.Fingerprint
  ( Fingerprint
  , fingerprint
  , fingerprintFile
  , fingerprintHexString
  ) where

import Control.DeepSeq          (NFData (rnf))
import Control.Exception        (try)
import Control.Monad            ((<$!>))
import Crypto.Hash.SHA256       (hash)
import Data.ByteString          (ByteString)
import Data.Char (intToDigit, digitToInt, isHexDigit)
import qualified Data.ByteString as B
import qualified Toml
import qualified Toml.Schema as Toml

newtype Fingerprint = Fingerprint ByteString
  deriving (Fingerprint -> Fingerprint -> Bool
(Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool) -> Eq Fingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fingerprint -> Fingerprint -> Bool
== :: Fingerprint -> Fingerprint -> Bool
$c/= :: Fingerprint -> Fingerprint -> Bool
/= :: Fingerprint -> Fingerprint -> Bool
Eq, Eq Fingerprint
Eq Fingerprint =>
(Fingerprint -> Fingerprint -> Ordering)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Fingerprint)
-> (Fingerprint -> Fingerprint -> Fingerprint)
-> Ord Fingerprint
Fingerprint -> Fingerprint -> Bool
Fingerprint -> Fingerprint -> Ordering
Fingerprint -> Fingerprint -> Fingerprint
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Fingerprint -> Fingerprint -> Ordering
compare :: Fingerprint -> Fingerprint -> Ordering
$c< :: Fingerprint -> Fingerprint -> Bool
< :: Fingerprint -> Fingerprint -> Bool
$c<= :: Fingerprint -> Fingerprint -> Bool
<= :: Fingerprint -> Fingerprint -> Bool
$c> :: Fingerprint -> Fingerprint -> Bool
> :: Fingerprint -> Fingerprint -> Bool
$c>= :: Fingerprint -> Fingerprint -> Bool
>= :: Fingerprint -> Fingerprint -> Bool
$cmax :: Fingerprint -> Fingerprint -> Fingerprint
max :: Fingerprint -> Fingerprint -> Fingerprint
$cmin :: Fingerprint -> Fingerprint -> Fingerprint
min :: Fingerprint -> Fingerprint -> Fingerprint
Ord, Int -> Fingerprint -> ShowS
[Fingerprint] -> ShowS
Fingerprint -> String
(Int -> Fingerprint -> ShowS)
-> (Fingerprint -> String)
-> ([Fingerprint] -> ShowS)
-> Show Fingerprint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Fingerprint -> ShowS
showsPrec :: Int -> Fingerprint -> ShowS
$cshow :: Fingerprint -> String
show :: Fingerprint -> String
$cshowList :: [Fingerprint] -> ShowS
showList :: [Fingerprint] -> ShowS
Show, ReadPrec [Fingerprint]
ReadPrec Fingerprint
Int -> ReadS Fingerprint
ReadS [Fingerprint]
(Int -> ReadS Fingerprint)
-> ReadS [Fingerprint]
-> ReadPrec Fingerprint
-> ReadPrec [Fingerprint]
-> Read Fingerprint
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Fingerprint
readsPrec :: Int -> ReadS Fingerprint
$creadList :: ReadS [Fingerprint]
readList :: ReadS [Fingerprint]
$creadPrec :: ReadPrec Fingerprint
readPrec :: ReadPrec Fingerprint
$creadListPrec :: ReadPrec [Fingerprint]
readListPrec :: ReadPrec [Fingerprint]
Read)

instance NFData Fingerprint where
  rnf :: Fingerprint -> ()
rnf (Fingerprint ByteString
fp) = ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
fp

-- | Compute a fingerprint for a bytestring.
fingerprint :: ByteString -> Fingerprint
fingerprint :: ByteString -> Fingerprint
fingerprint = ByteString -> Fingerprint
Fingerprint (ByteString -> Fingerprint)
-> (ByteString -> ByteString) -> ByteString -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hash

-- | Attempt to compute the fingerprint of the file at the given path.
-- Returns 'Left' in the case of an error.
fingerprintFile :: FilePath -> IO (Either IOError Fingerprint)
fingerprintFile :: String -> IO (Either IOError Fingerprint)
fingerprintFile String
path =
  do Either IOError ByteString
res <- IO ByteString -> IO (Either IOError ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO ByteString
B.readFile String
path)
     Either IOError Fingerprint -> IO (Either IOError Fingerprint)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOError Fingerprint -> IO (Either IOError Fingerprint))
-> Either IOError Fingerprint -> IO (Either IOError Fingerprint)
forall a b. (a -> b) -> a -> b
$! ByteString -> Fingerprint
fingerprint (ByteString -> Fingerprint)
-> Either IOError ByteString -> Either IOError Fingerprint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Either IOError ByteString
res :: Either IOError ByteString)

fingerprintHexString :: Fingerprint -> String
fingerprintHexString :: Fingerprint -> String
fingerprintHexString (Fingerprint ByteString
bs) = (Word8 -> ShowS) -> String -> ByteString -> String
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
B.foldr Word8 -> ShowS
forall {p}. Integral p => p -> ShowS
hex String
"" ByteString
bs
  where
  hex :: p -> ShowS
hex p
b String
cs = let (Int
x,Int
y) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod (p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
b) Int
16
             in Int -> Char
intToDigit Int
x Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Char
intToDigit Int
y Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs

fingerprintFromHexString :: String -> Maybe Fingerprint
fingerprintFromHexString :: String -> Maybe Fingerprint
fingerprintFromHexString String
str = ByteString -> Fingerprint
Fingerprint (ByteString -> Fingerprint)
-> ([Word8] -> ByteString) -> [Word8] -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
B.pack ([Word8] -> Fingerprint) -> Maybe [Word8] -> Maybe Fingerprint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [Word8]
forall {a}. Num a => String -> Maybe [a]
go String
str
  where
    go :: String -> Maybe [a]
go [] = [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
    go (Char
x:Char
y:String
z)
      | Char -> Bool
isHexDigit Char
x
      , Char -> Bool
isHexDigit Char
y
      = (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
y)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [a]
go String
z
    go String
_ = Maybe [a]
forall a. Maybe a
Nothing

instance Toml.ToValue Fingerprint where
  toValue :: Fingerprint -> Value
toValue = String -> Value
forall a. ToValue a => a -> Value
Toml.toValue (String -> Value)
-> (Fingerprint -> String) -> Fingerprint -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> String
fingerprintHexString

instance Toml.FromValue Fingerprint where
  fromValue :: forall l. Value' l -> Matcher l Fingerprint
fromValue Value' l
x =
   do String
str <- Value' l -> Matcher l String
forall l. Value' l -> Matcher l String
forall a l. FromValue a => Value' l -> Matcher l a
Toml.fromValue Value' l
x
      case String -> Maybe Fingerprint
fingerprintFromHexString String
str of
        Maybe Fingerprint
Nothing -> l -> String -> Matcher l Fingerprint
forall l a. l -> String -> Matcher l a
Toml.failAt (Value' l -> l
forall a. Value' a -> a
Toml.valueAnn Value' l
x) String
"malformed fingerprint hex-string"
        Just Fingerprint
fp -> Fingerprint -> Matcher l Fingerprint
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fingerprint
fp