wip

hbs2-core/hbs2-core.cabal

@@ -16,11 +16,79 @@ extra-doc-files:    CHANGELOG.md
 common warnings
     ghc-options: -Wall
 
+common shared-properties
+  ghc-options:
+        -Wall
+        -- -fno-warn-unused-matches
+        -- -fno-warn-unused-do-bind
+        -- -Werror=missing-methods
+        -- -Werror=incomplete-patterns
+        -- -fno-warn-unused-binds
+        -- -threaded
+        -- -rtsopts
+        -- "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+
+  default-language:    Haskell2010
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , QuasiQuotes
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+
+
+
 library
-    import:           warnings
+    import:           shared-properties
-    exposed-modules:  MyLib
+
+    exposed-modules:
+                      HBS2.Hash
+                    , HBS2.Prelude
+                    , HBS2.Prelude.Plated
+                    , HBS2.Storage
+
+
     -- other-modules:
     -- other-extensions:
     build-depends:    base ^>=4.15.1.0
+                     , aeson
+                     , async
+                     , base58-bytestring
+                     , binary
+                     , bytestring
+                     , cborg
+                     , containers
+                     , cryptonite
+                     , deepseq
+                     , hashable
+                     , interpolatedstring-perl6
+                     , memory
+                     , prettyprinter
+                     , safe
+                     , serialise
+                     , text
+                     , uniplate
+
     hs-source-dirs:   lib
     default-language: Haskell2010

hbs2-core/lib/HBS2/Hash.hs

@@ -0,0 +1,88 @@
+{-# Language RankNTypes #-}
+module HBS2.Hash
+  ( Serialise(..)
+  , module HBS2.Hash
+  )
+  where
+
+import Codec.Serialise
+import Crypto.Hash hiding (SHA1)
+import Data.Aeson(FromJSON(..),ToJSON(..),Value(..))
+import Data.Binary (Binary(..))
+import Data.ByteArray qualified as BA
+import Data.ByteString.Base58 (encodeBase58, bitcoinAlphabet, decodeBase58,Alphabet(..))
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Short qualified as SB
+import Data.ByteString.Short (ShortByteString)
+import Data.Data
+import Data.Hashable (Hashable)
+import Data.Kind
+import Data.String(IsString(..))
+import Data.Text qualified as Text
+import GHC.Generics
+import Prettyprinter
+import Text.InterpolatedString.Perl6 (qc)
+import Control.DeepSeq (NFData,force)
+
+data HbSync = HbSync
+              deriving stock (Data)
+
+
+data family Hash ( a :: Type )
+
+data HsHash
+
+type family HashType ( a :: Type) where
+  HashType HbSync = Blake2b_256
+
+newtype instance Hash HbSync =
+  HbSyncHash ShortByteString
+  deriving stock (Eq,Ord,Data,Generic)
+  deriving newtype (Hashable,Show)
+
+instance NFData (Hash HbSync)
+instance Serialise (Hash HbSync)
+instance Binary (Hash HbSync)
+
+newtype Internal a = Internal a
+
+class Hashed a where
+  hashObject :: a -> Hash HbSync
+
+alphabet :: Alphabet
+alphabet = bitcoinAlphabet
+
+getAlphabet :: [Char]
+getAlphabet = BS8.unpack (unAlphabet alphabet)
+
+
+instance Hashed ByteString where
+  hashObject s = HbSyncHash $ force $ SB.toShort $ BA.convert digest
+    where
+      digest = hash s :: Digest (HashType HbSync)
+
+instance Hashed LBS.ByteString where
+  hashObject s = HbSyncHash $ force $ SB.toShort $ BA.convert digest
+    where
+      digest = hashlazy s :: Digest (HashType HbSync)
+
+instance IsString (Hash HbSync) where
+  fromString s = maybe (error ("invalid base58: " <> show s)) HbSyncHash doDecode
+    where
+      doDecode = SB.toShort <$> decodeBase58 alphabet (BS8.pack s)
+
+instance Pretty (Hash HbSync) where
+  pretty (HbSyncHash s) = pretty @String [qc|{encodeBase58 bitcoinAlphabet (SB.fromShort s)}|]
+
+
+instance FromJSON (Hash HbSync) where
+  parseJSON = \case
+    String s -> pure (fromString (Text.unpack s))
+    _        -> fail "expected string"
+
+instance ToJSON (Hash HbSync) where
+  toJSON s = toJSON (show $ pretty s)
+
+

hbs2-core/lib/HBS2/Prelude.hs

@@ -0,0 +1,8 @@
+module HBS2.Prelude
+  ( module Data.String
+  ) where
+
+import Data.String (IsString(..))
+
+
+

hbs2-core/lib/HBS2/Prelude/Plated.hs

@@ -0,0 +1,25 @@
+module HBS2.Prelude.Plated
+  ( module HBS2.Prelude.Plated
+  , module Data.Data
+  , module Data.Generics.Uniplate.Operations
+  , Data
+  , Generic
+  ) where
+
+import Data.Data
+import Data.Generics.Uniplate.Data()
+import Data.Generics.Uniplate.Operations
+import GHC.Generics(Generic)
+import Safe
+
+uniLastMay :: forall to from . (Data from, Data to) => from -> Maybe to
+uniLastMay = lastMay . universeBi
+
+uniLastDef :: forall from to . (Data from, Data to) => to -> from -> to
+uniLastDef d = lastDef d . universeBi
+
+uniFirstMay :: forall to from . (Data from, Data to) => from -> Maybe to
+uniFirstMay = headMay . universeBi
+
+uniFirstDef :: forall from to . (Data from, Data to) => to -> from -> to
+uniFirstDef d = headDef d . universeBi

hbs2-core/lib/HBS2/Storage.hs

@@ -0,0 +1,18 @@
+{-# Language FunctionalDependencies #-}
+module HBS2.Storage where
+
+import Data.Kind
+
+type family Block block :: Type
+type family Key block   :: Type
+
+class Monad m => Storage a block m | a -> block where
+
+  putBlock :: a -> Block block -> m (Maybe (Key block))
+  getBlock :: a -> Key block -> m (Maybe (Block block))
+  listBlocks :: a -> ( Key block -> m () ) -> m ()
+
+
+
+
+

hbs2-core/lib/MyLib.hs

@@ -1,4 +0,0 @@
-module MyLib (someFunc) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"

hbs2-storage-simple/hbs2-storage-simple.cabal

@@ -13,14 +13,94 @@ build-type:         Simple
 extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
-common warnings
+common shared-properties
-    ghc-options: -Wall
+  ghc-options:
+        -Wall
+        -- -fno-warn-unused-matches
+        -- -fno-warn-unused-do-bind
+        -- -Werror=missing-methods
+        -- -Werror=incomplete-patterns
+        -- -fno-warn-unused-binds
+        -- -threaded
+        -- -rtsopts
+        -- "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+  default-language:    Haskell2010
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , QuasiQuotes
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+
+
 
 library
-    import:           warnings
+    import:           shared-properties
-    exposed-modules:  MyLib
+    exposed-modules:  HBS2.Storage.Simple
     -- other-modules:
     -- other-extensions:
-    build-depends:    base ^>=4.15.1.0
+    build-depends:    base ^>=4.15.1.0, hbs2-core
+                    , bytestring
+                    , containers
+                    , directory
+                    , filepath
+                    , uniplate
+                    , microlens-platform
+
+
     hs-source-dirs:   lib
     default-language: Haskell2010
+
+
+test-suite test
+    import:           shared-properties
+    default-language: Haskell2010
+
+    other-modules:
+
+    -- other-extensions:
+
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Main.hs
+
+    build-depends:
+          base ^>=4.15.1.0, hbs2-storage-simple, hbs2-core
+        , bytestring
+        , cborg
+        , containers
+        , hashable
+        , microlens-platform
+        , mtl
+        , prettyprinter
+        , random
+        , safe
+        , serialise
+        , tasty
+        , tasty-hunit
+        , transformers
+        , uniplate
+        , vector
+
+

hbs2-storage-simple/lib/HBS2/Storage/Simple.hs

@@ -0,0 +1,53 @@
+{-# Language TemplateHaskell #-}
+module HBS2.Storage.Simple where
+
+import Control.Monad.IO.Class
+import System.FilePath.Posix
+import Lens.Micro.Platform
+import Data.ByteString.Lazy qualified as LBS
+import System.Directory
+
+import HBS2.Storage
+import HBS2.Prelude
+import HBS2.Prelude.Plated
+
+newtype Raw a = Raw { fromRaw :: a }
+
+
+newtype StoragePrefix = StoragePrefix { fromPrefix :: FilePath }
+                        deriving stock (Data,Show)
+                        deriving newtype (IsString)
+
+newtype SimpleStorage =
+  SimpleStorage
+  { _storageDir :: FilePath
+  }
+
+makeLenses ''SimpleStorage
+
+storageBlocksDir :: SimpleStorage -> FilePath
+storageBlocksDir s = view storageDir s </> "blocks"
+
+storageBlocks :: SimpleGetter SimpleStorage FilePath
+storageBlocks = to f
+  where
+    f b = _storageDir b </> "blocks"
+
+
+simpleStorageInit :: (MonadIO m, Data opts) => opts -> m SimpleStorage
+simpleStorageInit opts = liftIO $ do
+  let prefix = uniLastDef "." opts :: StoragePrefix
+
+  pdir <- canonicalizePath (fromPrefix prefix)
+
+  let stor = SimpleStorage
+             { _storageDir = pdir
+             }
+
+  createDirectoryIfMissing True (stor ^. storageBlocks)
+
+  pure stor
+
+instance MonadIO m => Storage SimpleStorage (Raw LBS.ByteString) m where
+
+

hbs2-storage-simple/lib/MyLib.hs

@@ -1,4 +0,0 @@
-module MyLib (someFunc) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"

hbs2-storage-simple/test/Main.hs

@@ -0,0 +1,10 @@
+module Main where
+
+import HBS2.Storage
+
+
+
+main = do
+  error "oops"
+
+