{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Pantry.SHA256
(
SHA256
, SHA256Exception (..)
, hashFile
, hashBytes
, hashLazyBytes
, sinkHash
, fromHexText
, fromHexBytes
, fromDigest
, fromRaw
, toHexText
, toHexBytes
, toRaw
) where
import RIO
import Data.Aeson
import Database.Persist.Sql
import Pantry.Internal.StaticBytes
import Conduit
import qualified RIO.Text as T
import qualified Crypto.Hash.Conduit as Hash (hashFile, sinkHash)
import qualified Crypto.Hash as Hash (hash, hashlazy, Digest, SHA256)
import qualified Data.ByteArray
import qualified Data.ByteArray.Encoding as Mem
newtype SHA256 = SHA256 Bytes32
deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable)
data SHA256Exception
= InvalidByteCount !ByteString !StaticBytesException
| InvalidHexBytes !ByteString !Text
deriving (Typeable)
hashFile :: MonadIO m => FilePath -> m SHA256
hashFile fp = fromDigest <$> Hash.hashFile fp
hashBytes :: ByteString -> SHA256
hashBytes = fromDigest . Hash.hash
hashLazyBytes :: LByteString -> SHA256
hashLazyBytes = fromDigest . Hash.hashlazy
sinkHash :: Monad m => ConduitT ByteString o m SHA256
sinkHash = fromDigest <$> Hash.sinkHash
fromHexText :: Text -> Either SHA256Exception SHA256
fromHexText = fromHexBytes . encodeUtf8
fromHexBytes :: ByteString -> Either SHA256Exception SHA256
fromHexBytes hexBS = do
mapLeft (InvalidHexBytes hexBS . T.pack) (Mem.convertFromBase Mem.Base16 hexBS) >>= fromRaw
fromDigest :: Hash.Digest Hash.SHA256 -> SHA256
fromDigest digest =
case toStaticExact (Data.ByteArray.convert digest :: ByteString) of
Left e -> error $ "Impossible failure in fromDigest: " ++ show (digest, e)
Right x -> SHA256 x
fromRaw :: ByteString -> Either SHA256Exception SHA256
fromRaw bs = either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs)
toHexText :: SHA256 -> Text
toHexText ss =
case decodeUtf8' $ toHexBytes ss of
Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e)
Right t -> t
toHexBytes :: SHA256 -> ByteString
toHexBytes (SHA256 x) = Mem.convertToBase Mem.Base16 x
toRaw :: SHA256 -> ByteString
toRaw (SHA256 x) = Data.ByteArray.convert x
instance Show SHA256 where
show s = "SHA256 " ++ show (toHexText s)
instance PersistField SHA256 where
toPersistValue = PersistByteString . toRaw
fromPersistValue (PersistByteString bs) =
case toStaticExact bs of
Left e -> Left $ tshow e
Right ss -> pure $ SHA256 ss
fromPersistValue x = Left $ "Unexpected value: " <> tshow x
instance PersistFieldSql SHA256 where
sqlType _ = SqlBlob
instance Display SHA256 where
display = displayBytesUtf8 . toHexBytes
instance ToJSON SHA256 where
toJSON = toJSON . toHexText
instance FromJSON SHA256 where
parseJSON = withText "SHA256" $ \t ->
case fromHexText t of
Right x -> pure x
Left e -> fail $ concat
[ "Invalid SHA256 "
, show t
, ": "
, show e
]
instance Exception SHA256Exception
instance Show SHA256Exception where
show = T.unpack . utf8BuilderToText . display
instance Display SHA256Exception where
display (InvalidByteCount bs sbe) =
"Invalid byte count creating a SHA256 from " <>
displayShow bs <>
": " <>
displayShow sbe
display (InvalidHexBytes bs t) =
"Invalid hex bytes creating a SHA256: " <>
displayShow bs <>
": " <>
display t