basic love

flake.nix

@@ -13,8 +13,12 @@
         devShells.default = pkgs.mkShell {
           name = "hs";
 
+          nativeBuildInputs = with pkgs; [ pkg-config ];
+
           buildInputs = with pkgs; [
             zlib
+            libpq
+            haskellPackages.hspec-discover
           ];
         };
       });

hq-sample.cabal

@@ -16,9 +16,17 @@ extra-source-files:
 
 library
   exposed-modules:
-      Data.Track
+      Data.Persist.Tap
+      Data.Persist.TapTrans
+      Data.State.Track
+      Data.Types
       Env.Cache
+      Env.Persist.Tap
+      Infrastructure.Mongo
+      Infrastructure.Persist.Tap
       Lib
+      Serialize.Bson
+      Serialize.Str
   other-modules:
       Paths_hq_sample
   hs-source-dirs:
@@ -33,6 +41,10 @@ library
       FlexibleContexts
       DerivingStrategies
       GeneralizedNewtypeDeriving
+      NamedFieldPuns
+      FlexibleInstances
+      UndecidableInstances
+      ScopedTypeVariables
   build-depends:
       aeson
     , async
@@ -40,26 +52,23 @@ library
     , bytestring
     , conferer
     , containers
+    , data-default <0.8.0
+    , data-default-class <0.2
     , directory
     , generic-optics
     , hedis
     , katip
+    , mongoDB
     , mtl
     , optics
-    , persistent
-    , servant
-    , servant-client
-    , servant-quickcheck
-    , servant-server
-    , servant-swagger
+    , resource-pool
+    , spock
     , stm
     , text
     , time
     , transformers
     , unordered-containers
-    , wai
     , wai-websockets
-    , warp
     , websockets
   default-language: Haskell2010
 
@@ -79,6 +88,10 @@ executable hq-sample
       FlexibleContexts
       DerivingStrategies
       GeneralizedNewtypeDeriving
+      NamedFieldPuns
+      FlexibleInstances
+      UndecidableInstances
+      ScopedTypeVariables
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       aeson
@@ -87,34 +100,32 @@ executable hq-sample
     , bytestring
     , conferer
     , containers
+    , data-default <0.8.0
+    , data-default-class <0.2
     , directory
     , generic-optics
     , hedis
     , hq-sample
     , katip
+    , mongoDB
     , mtl
     , optics
-    , persistent
-    , servant
-    , servant-client
-    , servant-quickcheck
-    , servant-server
-    , servant-swagger
+    , resource-pool
+    , spock
     , stm
     , text
     , time
     , transformers
     , unordered-containers
-    , wai
     , wai-websockets
-    , warp
     , websockets
   default-language: Haskell2010
 
 test-suite hq-sample-test
   type: exitcode-stdio-1.0
-  main-is: Main.hs
+  main-is: Spec.hs
   other-modules:
+      Data.TypesSpec
       Paths_hq_sample
   hs-source-dirs:
       test
@@ -128,37 +139,39 @@ test-suite hq-sample-test
       FlexibleContexts
       DerivingStrategies
       GeneralizedNewtypeDeriving
+      NamedFieldPuns
+      FlexibleInstances
+      UndecidableInstances
+      ScopedTypeVariables
+  build-tool-depends:
+      hspec-discover:hspec-discover
   build-depends:
-      QuickCheck
-    , aeson
+      aeson
     , async
     , base
     , bytestring
     , conferer
     , containers
+    , data-default <0.8.0
+    , data-default-class <0.2
     , directory
     , generic-optics
     , hedis
     , hq-sample
+    , hspec
+    , hspec-discover
+    , hspec-wai
     , katip
+    , mongoDB
     , mtl
     , optics
-    , persistent
-    , servant
-    , servant-client
-    , servant-quickcheck
-    , servant-server
-    , servant-swagger
+    , resource-pool
+    , spock
     , stm
-    , tasty
-    , tasty-hunit
-    , tasty-quickcheck
     , text
     , time
     , transformers
     , unordered-containers
-    , wai
     , wai-websockets
-    , warp
     , websockets
   default-language: Haskell2010

package.yaml

@@ -16,6 +16,10 @@ default-extensions:
   - FlexibleContexts
   - DerivingStrategies
   - GeneralizedNewtypeDeriving
+  - NamedFieldPuns
+  - FlexibleInstances
+  - UndecidableInstances
+  - ScopedTypeVariables
 
 dependencies:
   - base
@@ -31,24 +35,22 @@ dependencies:
   - directory
   - time
 
-  - servant-swagger
-  - servant-server
-  - servant-client
-  - servant-quickcheck
-
-  - persistent
+  - mongoDB
   - hedis
   - katip
   - conferer
-  - warp
-  - wai
   - aeson
-  - servant
+
+  - spock
   - wai-websockets
   - websockets
+
   - stm
   - async
   - generic-optics
+  - resource-pool
+  - data-default-class < 0.2
+  - data-default < 0.8.0
 
 library:
   source-dirs: src
@@ -67,14 +69,15 @@ executables:
 
 tests:
   hq-sample-test:
-    main: Main.hs
+    main: Spec.hs
     source-dirs: test
+    build-tools:
+      - hspec-discover:hspec-discover
     dependencies:
       - base
 
       - hq-sample
 
-      - tasty
-      - tasty-hunit
-      - tasty-quickcheck
-      - QuickCheck
+      - hspec
+      - hspec-discover
+      - hspec-wai

src/Data/Persist/Tap.hs

@@ -0,0 +1,32 @@
+module Data.Persist.Tap where
+
+import Data.Coerce (coerce)
+import Data.Text (Text)
+import Data.Types (UserId)
+import Database.MongoDB
+import GHC.Generics (Generic)
+import Serialize.Bson (BsonTrans (..))
+import Serialize.Str
+
+newtype TapId = TapId Text
+    deriving (Show, Eq, Generic)
+
+data TapOccupation = Official | Verified | Base
+    deriving (Show, Eq, Generic)
+
+data TapRole = Music | TTS
+    deriving (Show, Eq, Generic)
+
+data TapPermissions = Public | OwnerOnly | Whitelist [UserId] | Blacklist [UserId]
+    deriving (Show, Eq, Generic)
+
+data Tap = Tap
+    { tapId :: TapId
+    , tapOwnerId :: UserId
+    , tapOccupation :: TapOccupation
+    , tapRoles :: [TapRole]
+    , tapPermissions :: TapPermissions
+    }
+    deriving (Show, Eq, Generic)
+
+newtype CreateTap = CreateTap Tap

src/Data/Persist/TapTrans.hs

@@ -0,0 +1,34 @@
+module Data.Persist.TapTrans where
+
+import Data.Coerce (coerce)
+import Data.Persist.Tap
+import Data.Text (Text)
+import qualified Data.Text as T
+import Serialize.Bson
+import Serialize.Str
+
+instance StrTrans TapOccupation where
+    toStr occu = case occu of
+        Official -> "official"
+        Verified -> "verified"
+        Base -> "base"
+
+    fromStr s = case s of
+        "official" -> Just Official
+        "verified" -> Just Verified
+        "base" -> Just Base
+        _ -> Nothing
+
+instance StrTrans TapRole where
+    toStr role = case role of
+        Music -> "music"
+        TTS -> "tts"
+
+    fromStr s = case s of
+        "music" -> Just Music
+        "tts" -> Just TTS
+        _ -> Nothing
+
+instance StrTrans TapId where
+    toStr = coerce
+    fromStr = Just . TapId

src/Data/State/Track.hs

@@ -1,4 +1,4 @@
-module Data.Track where
+module Data.State.Track where
 
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Word (Word64)
@@ -9,3 +9,4 @@ newtype TrackId = TrackId Word64
     deriving newtype (ToJSON, FromJSON)
 
 data Track = Track {trackId :: TrackId}
+    deriving (Show, Eq, Ord, Generic)

src/Data/Types.hs

@@ -0,0 +1,23 @@
+module Data.Types (UserId (..)) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHC.Generics (Generic)
+import Serialize.Str
+
+newtype UserId = Discord Text
+    deriving (Show, Eq, Generic)
+
+instance StrTrans UserId where
+    toStr userId = case userId of
+        Discord discordId -> "d:" <> discordId
+
+    fromStr s = do
+        let parts = T.splitOn ":" s
+        (kind, content) <- case parts of
+            (kind : content : _) -> Just (kind, content)
+            _ -> Nothing
+
+        case kind of
+            "d" -> pure $ Discord content
+            _ -> Nothing

src/Env/Cache.hs

@@ -1,4 +1,7 @@
 module Env.Cache where
 
+import Data.Text (Text)
+
 class (Monad m) => MonadCache m where
-    writeCache :: String -> String -> m ()
+    writeCache :: Text -> Text -> m ()
+    readCache :: Text -> m (Maybe String)

src/Env/Persist/Tap.hs

@@ -0,0 +1,8 @@
+module Env.Persist.Tap (MonadTaps (..)) where
+
+import Data.Persist.Tap (CreateTap, Tap, TapId)
+
+class (Monad m) => MonadTaps m where
+    createTap :: CreateTap -> m Tap
+    getTap :: TapId -> m (Maybe Tap)
+    deleteTap :: TapId -> m ()

src/Infrastructure/Mongo.hs

@@ -0,0 +1,41 @@
+module Infrastructure.Mongo where
+
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Reader (MonadReader (ask))
+import Control.Monad.Trans.Reader (ReaderT)
+import Data.Pool (Pool, PoolConfig, defaultPoolConfig, newPool, withResource)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Database.MongoDB (Host (Host), Pipe, PortID (PortNumber), access, close, connect)
+import Database.MongoDB.Query (Action, master)
+
+data MongoEnv = MongoEnv
+    { mongoPool :: Pool Pipe
+    , mongoDBName :: Text
+    }
+
+newtype MongoM a = MongoM {unMongoM :: ReaderT MongoEnv IO a}
+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader MongoEnv)
+
+mkMongoEnv :: Text -> Int -> Text -> IO MongoEnv
+mkMongoEnv host port dbName = do
+    let mongoHost = Host (T.unpack host) (PortNumber (fromIntegral port))
+
+    pool <-
+        newPool $
+            defaultPoolConfig
+                (connect mongoHost)
+                close
+                60 -- ttl
+                10 -- max resources
+    return
+        MongoEnv
+            { mongoPool = pool
+            , mongoDBName = dbName
+            }
+
+runMongoAction :: Action IO r -> MongoM r
+runMongoAction action = do
+    MongoEnv{mongoPool, mongoDBName} <- ask
+    liftIO $ withResource mongoPool $ \pipe ->
+        access pipe master mongoDBName action

src/Infrastructure/Persist/Tap.hs

@@ -0,0 +1,59 @@
+module Infrastructure.Persist.Tap where
+
+import Data.Persist.Tap
+import Data.Persist.TapTrans
+import Data.Text (Text)
+import Database.MongoDB
+import qualified Database.MongoDB as M
+import Env.Persist.Tap (MonadTaps (..))
+import Infrastructure.Mongo (MongoM, runMongoAction)
+import Serialize.Bson (BsonTrans (fromBson, toBson))
+import Serialize.Str (StrTrans (..))
+
+instance Val TapPermissions where
+    val Public = Doc ["type" =: ("public" :: Text)]
+    val OwnerOnly = Doc ["type" =: ("owner" :: Text)]
+    val (Whitelist uids) = Doc ["type" =: ("whitelist" :: Text), "users" =: uids]
+    val (Blacklist uids) = Doc ["type" =: ("blacklist" :: Text), "users" =: uids]
+
+    cast' (Doc d) = do
+        t <- cast' =<< M.lookup "type" d
+        case t :: Text of
+            "public" -> Just Public
+            "owner" -> Just OwnerOnly
+            "whitelist" -> Whitelist <$> (M.lookup "users" d >>= cast')
+            "blacklist" -> Blacklist <$> (M.lookup "users" d >>= cast')
+            _ -> Nothing
+    cast' _ = Nothing
+
+instance BsonTrans Tap where
+    toBson tap =
+        let roles = toStr <$> tapRoles tap
+         in ["id" =: tapId tap, "ownerId" =: tapOwnerId tap, "occupation" =: tapOccupation tap, "roles" =: roles, "permissions" =: tapPermissions tap]
+
+    fromBson bson = do
+        id <- g "id"
+        ownerId <- g "ownerId"
+        occupation <- g "occupation"
+        roles <- g "roles" :: Maybe [Text]
+        roles <- mapM fromStr roles
+        permissions <- g "permissions"
+
+        pure $ Tap{tapId = id, tapOwnerId = ownerId, tapOccupation = occupation, tapRoles = roles, tapPermissions = permissions}
+      where
+        g key = M.lookup key bson >>= cast'
+
+tapCollection :: Collection
+tapCollection = "taps"
+
+instance MonadTaps MongoM where
+    createTap (CreateTap tap) = runMongoAction $ do
+        insert tapCollection $ toBson tap
+        return tap
+
+    getTap id = runMongoAction $ do
+        doc <- findOne (select ["id" =: id] tapCollection)
+        return $ fromBson =<< doc
+
+    deleteTap id = runMongoAction $ do
+        delete (select ["id" =: id] tapCollection)

src/Serialize/Bson.hs

@@ -0,0 +1,7 @@
+module Serialize.Bson (BsonTrans (..)) where
+
+import Database.MongoDB
+
+class BsonTrans a where
+    toBson :: a -> Document
+    fromBson :: Document -> Maybe a

src/Serialize/Str.hs

@@ -0,0 +1,16 @@
+module Serialize.Str (StrTrans (..)) where
+
+import Data.Data (Typeable)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Database.MongoDB
+
+class StrTrans a where
+  toStr :: a -> Text
+  fromStr :: Text -> Maybe a
+
+instance {-# OVERLAPPABLE #-} (StrTrans a, Eq a, Show a, Typeable a) => Val a where
+  val = String . toStr
+
+  cast' (String d) = fromStr d
+  cast' _ = Nothing

test/Data/TypesSpec.hs

@@ -0,0 +1,16 @@
+module Data.TypesSpec (spec) where
+
+import Data.Types (UserId (..))
+import Serialize.Str
+import Test.Hspec
+
+spec :: Spec
+spec = describe "userId StringTrans" $ do
+    it "fromStr should convert String to UserId::Discord" $ do
+        fromStr "d:muffin" `shouldBe` Just (Discord "muffin")
+
+    it "fromStr should fail conversion" $ do
+        (fromStr "muffin" :: Maybe UserId) `shouldBe` Nothing
+
+    it "toStr should convert UserId to String" $ do
+        toStr (Discord "muffin") `shouldBe` "d:muffin"

test/Main.hs

@@ -1,26 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Main (main) where
-
-import Data.List (isInfixOf)
-import Test.Tasty
-import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck as QC
-
-main :: IO ()
-main = spec >>= defaultMain
-
-spec :: IO TestTree
-spec = return $ testGroup "example tests" [baseTests]
-
-baseTests :: TestTree
-baseTests =
-    testGroup
-        "Base"
-        [ QC.testProperty "example function works" $
-            \(num :: Integer) ->
-                num * 0 == 0
-        ]

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}