{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |

module Casa.Types where

import           Control.Monad
import           Data.Aeson
import qualified Data.Attoparsec.ByteString as Atto.B
import qualified Data.Attoparsec.Text as Atto.T
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as Hex
import qualified Data.ByteString.Builder as S
import           Data.Hashable
import           Database.Persist
import           Database.Persist.Sql
import           Data.Text (Text)
import qualified Data.Text.Encoding as T
import           Web.PathPieces

-- | A SHA256 key to address blobs.
newtype BlobKey =
  BlobKey
    { BlobKey -> ByteString
unBlobKey :: ByteString
    }
  deriving (ReadPrec [BlobKey]
ReadPrec BlobKey
Int -> ReadS BlobKey
ReadS [BlobKey]
(Int -> ReadS BlobKey)
-> ReadS [BlobKey]
-> ReadPrec BlobKey
-> ReadPrec [BlobKey]
-> Read BlobKey
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BlobKey]
$creadListPrec :: ReadPrec [BlobKey]
readPrec :: ReadPrec BlobKey
$creadPrec :: ReadPrec BlobKey
readList :: ReadS [BlobKey]
$creadList :: ReadS [BlobKey]
readsPrec :: Int -> ReadS BlobKey
$creadsPrec :: Int -> ReadS BlobKey
Read, BlobKey -> BlobKey -> Bool
(BlobKey -> BlobKey -> Bool)
-> (BlobKey -> BlobKey -> Bool) -> Eq BlobKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlobKey -> BlobKey -> Bool
$c/= :: BlobKey -> BlobKey -> Bool
== :: BlobKey -> BlobKey -> Bool
$c== :: BlobKey -> BlobKey -> Bool
Eq, Eq BlobKey
Eq BlobKey
-> (BlobKey -> BlobKey -> Ordering)
-> (BlobKey -> BlobKey -> Bool)
-> (BlobKey -> BlobKey -> Bool)
-> (BlobKey -> BlobKey -> Bool)
-> (BlobKey -> BlobKey -> Bool)
-> (BlobKey -> BlobKey -> BlobKey)
-> (BlobKey -> BlobKey -> BlobKey)
-> Ord BlobKey
BlobKey -> BlobKey -> Bool
BlobKey -> BlobKey -> Ordering
BlobKey -> BlobKey -> BlobKey
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
min :: BlobKey -> BlobKey -> BlobKey
$cmin :: BlobKey -> BlobKey -> BlobKey
max :: BlobKey -> BlobKey -> BlobKey
$cmax :: BlobKey -> BlobKey -> BlobKey
>= :: BlobKey -> BlobKey -> Bool
$c>= :: BlobKey -> BlobKey -> Bool
> :: BlobKey -> BlobKey -> Bool
$c> :: BlobKey -> BlobKey -> Bool
<= :: BlobKey -> BlobKey -> Bool
$c<= :: BlobKey -> BlobKey -> Bool
< :: BlobKey -> BlobKey -> Bool
$c< :: BlobKey -> BlobKey -> Bool
compare :: BlobKey -> BlobKey -> Ordering
$ccompare :: BlobKey -> BlobKey -> Ordering
$cp1Ord :: Eq BlobKey
Ord, Int -> BlobKey -> Int
BlobKey -> Int
(Int -> BlobKey -> Int) -> (BlobKey -> Int) -> Hashable BlobKey
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: BlobKey -> Int
$chash :: BlobKey -> Int
hashWithSalt :: Int -> BlobKey -> Int
$chashWithSalt :: Int -> BlobKey -> Int
Hashable, PersistValue -> Either Text BlobKey
BlobKey -> PersistValue
(BlobKey -> PersistValue)
-> (PersistValue -> Either Text BlobKey) -> PersistField BlobKey
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text BlobKey
$cfromPersistValue :: PersistValue -> Either Text BlobKey
toPersistValue :: BlobKey -> PersistValue
$ctoPersistValue :: BlobKey -> PersistValue
PersistField, PersistField BlobKey
Proxy BlobKey -> SqlType
PersistField BlobKey
-> (Proxy BlobKey -> SqlType) -> PersistFieldSql BlobKey
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy BlobKey -> SqlType
$csqlType :: Proxy BlobKey -> SqlType
$cp1PersistFieldSql :: PersistField BlobKey
PersistFieldSql)

instance Show BlobKey where
  show :: BlobKey -> String
show (BlobKey ByteString
key) = ByteString -> String
forall a. Show a => a -> String
show (ByteString -> ByteString
Hex.encode ByteString
key)

instance FromJSON BlobKey where
  parseJSON :: Value -> Parser BlobKey
parseJSON = Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Text)
-> (Text -> Parser BlobKey) -> Value -> Parser BlobKey
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ((String -> Parser BlobKey)
-> (BlobKey -> Parser BlobKey)
-> Either String BlobKey
-> Parser BlobKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser BlobKey
forall (m :: * -> *) a. MonadFail m => String -> m a
fail BlobKey -> Parser BlobKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String BlobKey -> Parser BlobKey)
-> (Text -> Either String BlobKey) -> Text -> Parser BlobKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String BlobKey
blobKeyHexParser)

instance ToJSON BlobKey where
  toJSON :: BlobKey -> Value
toJSON = Text -> Value
String (Text -> Value) -> (BlobKey -> Text) -> BlobKey -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (BlobKey -> ByteString) -> BlobKey -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Hex.encode (ByteString -> ByteString)
-> (BlobKey -> ByteString) -> BlobKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlobKey -> ByteString
unBlobKey

instance PathPiece BlobKey where
  fromPathPiece :: Text -> Maybe BlobKey
fromPathPiece =
    (String -> Maybe BlobKey)
-> (BlobKey -> Maybe BlobKey)
-> Either String BlobKey
-> Maybe BlobKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe BlobKey -> String -> Maybe BlobKey
forall a b. a -> b -> a
const Maybe BlobKey
forall a. Maybe a
Nothing) BlobKey -> Maybe BlobKey
forall a. a -> Maybe a
Just (Either String BlobKey -> Maybe BlobKey)
-> (Text -> Either String BlobKey) -> Text -> Maybe BlobKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Text -> Either String BlobKey
blobKeyHexParser
  toPathPiece :: BlobKey -> Text
toPathPiece = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (BlobKey -> ByteString) -> BlobKey -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Hex.encode (ByteString -> ByteString)
-> (BlobKey -> ByteString) -> BlobKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlobKey -> ByteString
unBlobKey

-- | Parse a blob key in hex format.
blobKeyHexParser :: Text -> Either String BlobKey
blobKeyHexParser :: Text -> Either String BlobKey
blobKeyHexParser =
  Parser BlobKey -> Text -> Either String BlobKey
forall a. Parser a -> Text -> Either String a
Atto.T.parseOnly
    ((ByteString -> BlobKey) -> Parser Text ByteString -> Parser BlobKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
       ByteString -> BlobKey
BlobKey
       (do Text
bytes <- Int -> Parser Text
Atto.T.take Int
64
           case ByteString -> Either String ByteString
Hex.decode (Text -> ByteString
T.encodeUtf8 Text
bytes) of
             Right ByteString
result -> ByteString -> Parser Text ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
result
             Left String
_ -> String -> Parser Text ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid hex key."))

-- | Parse a blob key in binary format.
blobKeyBinaryParser :: Atto.B.Parser BlobKey
blobKeyBinaryParser :: Parser BlobKey
blobKeyBinaryParser = (ByteString -> BlobKey)
-> Parser ByteString ByteString -> Parser BlobKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> BlobKey
BlobKey (Int -> Parser ByteString ByteString
Atto.B.take Int
32)

blobKeyToBuilder :: BlobKey -> S.Builder
blobKeyToBuilder :: BlobKey -> Builder
blobKeyToBuilder = ByteString -> Builder
S.byteString (ByteString -> Builder)
-> (BlobKey -> ByteString) -> BlobKey -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlobKey -> ByteString
unBlobKey