module Network.IPFS.SparseTree.Types
  ( SparseTree (..)
  , Tag (..)
  ) where

import qualified RIO.HashMap as HashMap
import qualified RIO.Map     as Map
import qualified RIO.Text    as Text

import Data.Swagger hiding (Tag, name)
import Servant

import           Network.IPFS.Prelude
import qualified Network.IPFS.Internal.UTF8 as UTF8
import           Network.IPFS.CID.Types
import           Network.IPFS.Name.Types

-- | Directory structure for CIDs and other identifiers
--
-- Examples:
--
-- > Content "abcdef"
--
-- > show $ Directory [(Key "abcdef", Stub "myfile.txt")])]
-- "abcdef/myfile.txt"
data SparseTree
  = Stub Name
  | Content CID
  | Directory (Map Tag SparseTree)
  deriving          ( SparseTree -> SparseTree -> Bool
(SparseTree -> SparseTree -> Bool)
-> (SparseTree -> SparseTree -> Bool) -> Eq SparseTree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SparseTree -> SparseTree -> Bool
$c/= :: SparseTree -> SparseTree -> Bool
== :: SparseTree -> SparseTree -> Bool
$c== :: SparseTree -> SparseTree -> Bool
Eq
                    , (forall x. SparseTree -> Rep SparseTree x)
-> (forall x. Rep SparseTree x -> SparseTree) -> Generic SparseTree
forall x. Rep SparseTree x -> SparseTree
forall x. SparseTree -> Rep SparseTree x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SparseTree x -> SparseTree
$cfrom :: forall x. SparseTree -> Rep SparseTree x
Generic
                    , Int -> SparseTree -> ShowS
[SparseTree] -> ShowS
SparseTree -> String
(Int -> SparseTree -> ShowS)
-> (SparseTree -> String)
-> ([SparseTree] -> ShowS)
-> Show SparseTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SparseTree] -> ShowS
$cshowList :: [SparseTree] -> ShowS
show :: SparseTree -> String
$cshow :: SparseTree -> String
showsPrec :: Int -> SparseTree -> ShowS
$cshowsPrec :: Int -> SparseTree -> ShowS
Show
                    )

instance ToSchema SparseTree where
  declareNamedSchema :: Proxy SparseTree -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy SparseTree
_ =
    Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
|> (Maybe (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_       ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> Schema -> Identity Schema)
-> SwaggerType 'SwaggerKindSchema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
forall (t :: SwaggerKind *). SwaggerType t
SwaggerString
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
|> (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
description ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"A tree of IPFS paths"
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
|> (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
example     ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SparseTree -> Value
forall a. ToJSON a => a -> Value
toJSON (Map Tag SparseTree -> SparseTree
Directory [(Name -> Tag
Key Name
"abcdef", Name -> SparseTree
Stub Name
"myfile.txt")])
      Schema -> (Schema -> NamedSchema) -> NamedSchema
forall a b. a -> (a -> b) -> b
|> Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"IPFSTree")
      NamedSchema
-> (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> Declare (Definitions Schema) NamedSchema
forall a b. a -> (a -> b) -> b
|> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Display (Map Tag SparseTree) where
  display :: Map Tag SparseTree -> Utf8Builder
display Map Tag SparseTree
sparseMap =
    Utf8Builder
"{" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (Utf8Builder -> Utf8Builder -> Utf8Builder)
-> Utf8Builder -> [Utf8Builder] -> Utf8Builder
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Utf8Builder
e Utf8Builder
acc -> Utf8Builder
e Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
acc) Utf8Builder
"}" ((Tag, SparseTree) -> Utf8Builder
forall a a. (Display a, Display a) => (a, a) -> Utf8Builder
prettyKV ((Tag, SparseTree) -> Utf8Builder)
-> [(Tag, SparseTree)] -> [Utf8Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Tag SparseTree -> [(Tag, SparseTree)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Tag SparseTree
sparseMap)
    where
      prettyKV :: (a, a) -> Utf8Builder
prettyKV (a
k, a
v) = a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
k Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" => " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
v

instance Display SparseTree where
  display :: SparseTree -> Utf8Builder
display = \case
    Stub      Name
name -> Name -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Name
name
    Content   CID
cid  -> CID -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display CID
cid
    Directory Map Tag SparseTree
dir  -> Map Tag SparseTree -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Map Tag SparseTree
dir

instance ToJSON SparseTree where
  toJSON :: SparseTree -> Value
toJSON = \case
    Stub (Name String
name)  -> Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
<| String -> Text
Text.pack String
name
    Content (CID Text
cid) -> Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
<| Natural -> Text -> Text
UTF8.stripN Natural
1 Text
cid
    Directory Map Tag SparseTree
dirMap  -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
<| [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ((Tag, SparseTree) -> (Text, Value)
jsonKV ((Tag, SparseTree) -> (Text, Value))
-> [(Tag, SparseTree)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Tag SparseTree -> [(Tag, SparseTree)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Tag SparseTree
dirMap)
    where
      jsonKV :: (Tag, SparseTree) -> (Text, Value)
      jsonKV :: (Tag, SparseTree) -> (Text, Value)
jsonKV (Tag
tag, SparseTree
subtree) = (Tag -> Text
jsonTag Tag
tag, SparseTree -> Value
forall a. ToJSON a => a -> Value
toJSON SparseTree
subtree)

      jsonTag :: Tag -> Text
jsonTag (Key (Name String
n))   = String -> Text
Text.pack String
n
      jsonTag (Hash (CID Text
cid)) = Natural -> Text -> Text
UTF8.stripN Natural
1 Text
cid

data Tag
  = Key Name
  | Hash CID
  deriving ( Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq
           , (forall x. Tag -> Rep Tag x)
-> (forall x. Rep Tag x -> Tag) -> Generic Tag
forall x. Rep Tag x -> Tag
forall x. Tag -> Rep Tag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Tag x -> Tag
$cfrom :: forall x. Tag -> Rep Tag x
Generic
           , Eq Tag
Eq Tag
-> (Tag -> Tag -> Ordering)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Tag)
-> (Tag -> Tag -> Tag)
-> Ord Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
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 :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
$cp1Ord :: Eq Tag
Ord
           , Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> String
$cshow :: Tag -> String
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show
           )

instance Display Tag where
  display :: Tag -> Utf8Builder
display (Key Name
name) = Name -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Name
name
  display (Hash CID
cid) = CID -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display CID
cid

instance FromJSON Tag
instance ToJSON Tag where
  toJSON :: Tag -> Value
toJSON (Key Name
k)  = Name -> Value
forall a. ToJSON a => a -> Value
toJSON Name
k
  toJSON (Hash CID
h) = CID -> Value
forall a. ToJSON a => a -> Value
toJSON CID
h

instance FromJSONKey Tag
instance ToJSONKey Tag
instance ToSchema Tag

instance FromHttpApiData Tag where
  parseUrlPiece :: Text -> Either Text Tag
parseUrlPiece Text
txt = Name -> Tag
Key (Name -> Tag) -> Either Text Name -> Either Text Tag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Name
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
txt