{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-|
Description : Cryptographic hashing interface for hnix-store, on top
              of the cryptohash family of libraries.
-}

module System.Nix.Hash
  ( HashAlgo(..)
  , NamedAlgo(..)
  , algoToText
  , textToAlgo
  , mkNamedDigest

  , mkStorePathHash

  , System.Nix.Base.BaseEncoding(..)
  , encodeDigestWith
  , decodeDigestWith

  , algoDigestBuilder
  , digestBuilder
  ) where

import Crypto.Hash (Digest, HashAlgorithm, MD5(..), SHA1(..), SHA256(..), SHA512(..))
import Data.ByteString (ByteString)
import Data.Constraint.Extras (Has(has))
import Data.Constraint.Extras.TH (deriveArgDict)
import Data.Dependent.Sum (DSum((:=>)))
import Data.GADT.Compare.TH (deriveGEq, deriveGCompare)
import Data.GADT.Show.TH (deriveGShow)
import Data.Kind (Type)
import Data.Some (Some(Some))
import Data.Text (Text)
import Data.Text.Lazy.Builder (Builder)
import System.Nix.Base (BaseEncoding(..))

import qualified Crypto.Hash
import qualified Data.ByteArray
import qualified Data.Text
import qualified Data.Text.Lazy.Builder
import qualified System.Nix.Base
import qualified System.Nix.Hash.Truncation

-- | A 'HashAlgorithm' with a canonical name, for serialization
-- purposes (e.g. SRI hashes)
class HashAlgorithm a => NamedAlgo a where
  algoName :: Text

instance NamedAlgo MD5 where
  algoName :: Text
algoName = Text
"md5"

instance NamedAlgo SHA1 where
  algoName :: Text
algoName = Text
"sha1"

instance NamedAlgo SHA256 where
  algoName :: Text
algoName = Text
"sha256"

instance NamedAlgo SHA512 where
  algoName :: Text
algoName = Text
"sha512"

data HashAlgo :: Type -> Type where
  HashAlgo_MD5 :: HashAlgo MD5
  HashAlgo_SHA1 :: HashAlgo SHA1
  HashAlgo_SHA256 :: HashAlgo SHA256
  HashAlgo_SHA512 :: HashAlgo SHA512

deriveGEq ''HashAlgo
deriveGCompare ''HashAlgo
deriveGShow ''HashAlgo
deriveArgDict ''HashAlgo

algoToText :: forall t. HashAlgo t -> Text
algoToText :: forall t. HashAlgo t -> Text
algoToText HashAlgo t
x = forall {k} (c :: k -> Constraint) (f :: k -> *) (a :: k) r.
Has c f =>
f a -> (c a => r) -> r
forall (c :: * -> Constraint) (f :: * -> *) a r.
Has c f =>
f a -> (c a => r) -> r
has @NamedAlgo HashAlgo t
x (forall a. NamedAlgo a => Text
algoName @t)

hashAlgoValue :: HashAlgo a -> a
hashAlgoValue :: forall a. HashAlgo a -> a
hashAlgoValue = \case
  HashAlgo a
HashAlgo_MD5 -> a
MD5
MD5
  HashAlgo a
HashAlgo_SHA1 -> a
SHA1
SHA1
  HashAlgo a
HashAlgo_SHA256 -> a
SHA256
SHA256
  HashAlgo a
HashAlgo_SHA512 -> a
SHA512
SHA512

textToAlgo :: Text -> Either String (Some HashAlgo)
textToAlgo :: Text -> Either String (Some HashAlgo)
textToAlgo = \case
    Text
"md5"    -> Some HashAlgo -> Either String (Some HashAlgo)
forall a b. b -> Either a b
Right (Some HashAlgo -> Either String (Some HashAlgo))
-> Some HashAlgo -> Either String (Some HashAlgo)
forall a b. (a -> b) -> a -> b
$ HashAlgo MD5 -> Some HashAlgo
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some HashAlgo MD5
HashAlgo_MD5
    Text
"sha1"   -> Some HashAlgo -> Either String (Some HashAlgo)
forall a b. b -> Either a b
Right (Some HashAlgo -> Either String (Some HashAlgo))
-> Some HashAlgo -> Either String (Some HashAlgo)
forall a b. (a -> b) -> a -> b
$ HashAlgo SHA1 -> Some HashAlgo
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some HashAlgo SHA1
HashAlgo_SHA1
    Text
"sha256" -> Some HashAlgo -> Either String (Some HashAlgo)
forall a b. b -> Either a b
Right (Some HashAlgo -> Either String (Some HashAlgo))
-> Some HashAlgo -> Either String (Some HashAlgo)
forall a b. (a -> b) -> a -> b
$ HashAlgo SHA256 -> Some HashAlgo
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some HashAlgo SHA256
HashAlgo_SHA256
    Text
"sha512" -> Some HashAlgo -> Either String (Some HashAlgo)
forall a b. b -> Either a b
Right (Some HashAlgo -> Either String (Some HashAlgo))
-> Some HashAlgo -> Either String (Some HashAlgo)
forall a b. (a -> b) -> a -> b
$ HashAlgo SHA512 -> Some HashAlgo
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some HashAlgo SHA512
HashAlgo_SHA512
    Text
name     -> String -> Either String (Some HashAlgo)
forall a b. a -> Either a b
Left (String -> Either String (Some HashAlgo))
-> String -> Either String (Some HashAlgo)
forall a b. (a -> b) -> a -> b
$ String
"Unknown hash name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Data.Text.unpack Text
name

-- | Make @DSum HashAlgo Digest@ based on provided SRI hash name
-- and its encoded form
mkNamedDigest
  :: Text -- ^ SRI name
  -> Text -- ^ base encoded hash
  -> Either String (DSum HashAlgo Digest)
mkNamedDigest :: Text -> Text -> Either String (DSum HashAlgo Digest)
mkNamedDigest Text
name Text
sriHash =
  let (Text
sriName, Text
h) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Data.Text.breakOnEnd Text
"-" Text
sriHash in
    if Text
sriName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" Bool -> Bool -> Bool
|| Text
sriName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-"
    then Text -> Either String (DSum HashAlgo Digest)
mkDigest Text
h
    else
      String -> Either String (DSum HashAlgo Digest)
forall a b. a -> Either a b
Left
      (String -> Either String (DSum HashAlgo Digest))
-> String -> Either String (DSum HashAlgo Digest)
forall a b. (a -> b) -> a -> b
$ Text -> String
Data.Text.unpack
      (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Sri hash method"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sriName
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"does not match the required hash type"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
 where
  mkDigest :: Text -> Either String (DSum HashAlgo Digest)
mkDigest Text
h =
    Text -> Either String (Some HashAlgo)
textToAlgo Text
name
    Either String (Some HashAlgo)
-> (Some HashAlgo -> Either String (DSum HashAlgo Digest))
-> Either String (DSum HashAlgo Digest)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Some HashAlgo a
a) -> forall {k} (c :: k -> Constraint) (f :: k -> *) (a :: k) r.
Has c f =>
f a -> (c a => r) -> r
forall (c :: * -> Constraint) (f :: * -> *) a r.
Has c f =>
f a -> (c a => r) -> r
has @HashAlgorithm HashAlgo a
a ((HashAlgorithm a => Either String (DSum HashAlgo Digest))
 -> Either String (DSum HashAlgo Digest))
-> (HashAlgorithm a => Either String (DSum HashAlgo Digest))
-> Either String (DSum HashAlgo Digest)
forall a b. (a -> b) -> a -> b
$ (Digest a -> DSum HashAlgo Digest)
-> Either String (Digest a) -> Either String (DSum HashAlgo Digest)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HashAlgo a
a HashAlgo a -> Digest a -> DSum HashAlgo Digest
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (Either String (Digest a) -> Either String (DSum HashAlgo Digest))
-> Either String (Digest a) -> Either String (DSum HashAlgo Digest)
forall a b. (a -> b) -> a -> b
$ HashAlgo a -> Text -> Either String (Digest a)
forall a.
HashAlgorithm a =>
HashAlgo a -> Text -> Either String (Digest a)
decodeGo HashAlgo a
a Text
h
  decodeGo :: HashAlgorithm a => HashAlgo a -> Text -> Either String (Digest a)
  decodeGo :: forall a.
HashAlgorithm a =>
HashAlgo a -> Text -> Either String (Digest a)
decodeGo HashAlgo a
a Text
h
    | Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
base16Len = BaseEncoding -> Text -> Either String (Digest a)
forall a.
HashAlgorithm a =>
BaseEncoding -> Text -> Either String (Digest a)
decodeDigestWith BaseEncoding
Base16 Text
h
    | Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
base32Len = BaseEncoding -> Text -> Either String (Digest a)
forall a.
HashAlgorithm a =>
BaseEncoding -> Text -> Either String (Digest a)
decodeDigestWith BaseEncoding
NixBase32 Text
h
    | Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
base64Len = BaseEncoding -> Text -> Either String (Digest a)
forall a.
HashAlgorithm a =>
BaseEncoding -> Text -> Either String (Digest a)
decodeDigestWith BaseEncoding
Base64 Text
h
    | Bool
otherwise =
        String -> Either String (Digest a)
forall a b. a -> Either a b
Left
        (String -> Either String (Digest a))
-> String -> Either String (Digest a)
forall a b. (a -> b) -> a -> b
$ Text -> String
Data.Text.unpack
        (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
sriHash
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"is not a valid"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"hash. Its length ("
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Data.Text.pack (Int -> String
forall a. Show a => a -> String
show Int
size)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") does not match any of"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Data.Text.pack ([Int] -> String
forall a. Show a => a -> String
show [Int
base16Len, Int
base32Len, Int
base64Len])
   where
    size :: Int
size = Text -> Int
Data.Text.length Text
h
    hsize :: Int
hsize = a -> Int
forall a. HashAlgorithm a => a -> Int
Crypto.Hash.hashDigestSize (HashAlgo a -> a
forall a. HashAlgo a -> a
hashAlgoValue HashAlgo a
a)
    base16Len :: Int
base16Len = Int
hsize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
    base32Len :: Int
base32Len = ((Int
hsize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1;
    base64Len :: Int
base64Len = ((Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hsize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4;

mkStorePathHash
  :: forall a
   . HashAlgorithm a
  => ByteString
  -> ByteString
mkStorePathHash :: forall a. HashAlgorithm a => ByteString -> ByteString
mkStorePathHash ByteString
bs =
  Int -> ByteString -> ByteString
System.Nix.Hash.Truncation.truncateInNixWay Int
20
  (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest a -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Data.ByteArray.convert
  (Digest a -> ByteString) -> Digest a -> ByteString
forall a b. (a -> b) -> a -> b
$ forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Crypto.Hash.hash @ByteString @a ByteString
bs

-- | Take BaseEncoding type of the output -> take the Digeest as input -> encode Digest
encodeDigestWith :: BaseEncoding -> Digest a -> Text
encodeDigestWith :: forall a. BaseEncoding -> Digest a -> Text
encodeDigestWith BaseEncoding
b = BaseEncoding -> ByteString -> Text
System.Nix.Base.encodeWith BaseEncoding
b (ByteString -> Text)
-> (Digest a -> ByteString) -> Digest a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest a -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Data.ByteArray.convert

-- | Take BaseEncoding type of the input -> take the input itself -> decodeBase into Digest
decodeDigestWith
  :: HashAlgorithm a
  => BaseEncoding
  -> Text
  -> Either String (Digest a)
decodeDigestWith :: forall a.
HashAlgorithm a =>
BaseEncoding -> Text -> Either String (Digest a)
decodeDigestWith BaseEncoding
b Text
x =
  do
    ByteString
bs <- BaseEncoding -> Text -> Either String ByteString
System.Nix.Base.decodeWith BaseEncoding
b Text
x
    let
      toEither :: Maybe (Digest a) -> Either String (Digest a)
toEither =
        String -> Maybe (Digest a) -> Either String (Digest a)
forall b a. b -> Maybe a -> Either b a
maybeToRight
          (String
"Crypton was not able to convert '(ByteString -> Digest a)' for: '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
bs String -> ShowS
forall a. Semigroup a => a -> a -> a
<>String
"'.")
    (Maybe (Digest a) -> Either String (Digest a)
toEither (Maybe (Digest a) -> Either String (Digest a))
-> (ByteString -> Maybe (Digest a))
-> ByteString
-> Either String (Digest a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Digest a)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
Crypto.Hash.digestFromByteString) ByteString
bs
  where
    -- To not depend on @extra@
    maybeToRight :: b -> Maybe a -> Either b a
    maybeToRight :: forall b a. b -> Maybe a -> Either b a
maybeToRight b
_ (Just a
r) = a -> Either b a
forall a. a -> Either b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
    maybeToRight b
y Maybe a
Nothing  = b -> Either b a
forall a b. a -> Either a b
Left b
y

-- | Builder for @Digest@s
digestBuilder :: forall hashAlgo . (NamedAlgo hashAlgo) => Digest hashAlgo -> Builder
digestBuilder :: forall hashAlgo. NamedAlgo hashAlgo => Digest hashAlgo -> Builder
digestBuilder Digest hashAlgo
digest =
  Text -> Builder
Data.Text.Lazy.Builder.fromText (forall a. NamedAlgo a => Text
System.Nix.Hash.algoName @hashAlgo)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":"
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Data.Text.Lazy.Builder.fromText
      (BaseEncoding -> Digest hashAlgo -> Text
forall a. BaseEncoding -> Digest a -> Text
System.Nix.Hash.encodeDigestWith BaseEncoding
NixBase32 Digest hashAlgo
digest)

-- | Builder for @DSum HashAlgo Digest@s
algoDigestBuilder :: DSum HashAlgo Digest -> Builder
algoDigestBuilder :: DSum HashAlgo Digest -> Builder
algoDigestBuilder (HashAlgo a
a :=> Digest a
d) =
  Text -> Builder
Data.Text.Lazy.Builder.fromText (HashAlgo a -> Text
forall t. HashAlgo t -> Text
System.Nix.Hash.algoToText HashAlgo a
a)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":"
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Data.Text.Lazy.Builder.fromText (BaseEncoding -> Digest a -> Text
forall a. BaseEncoding -> Digest a -> Text
encodeDigestWith BaseEncoding
NixBase32 Digest a
d)