Polysemy fun with minio-hs

minio-hs-polysemy.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings#-}
{-# LANGUAGE LambdaCase, BlockArguments #-}
{-# LANGUAGE GADTs, FlexibleContexts, TypeOperators, DataKinds, PolyKinds, ScopedTypeVariables #-}
import           Network.Minio

import qualified Data.HashMap.Strict      as HM
import qualified Data.ByteString          as B
import           Polysemy
import           Polysemy.Input
import           Polysemy.State
import           Polysemy.Error
import           Data.Monoid              ((<>))
import           Data.Text                (Text, pack)
import           Options.Applicative
import           System.FilePath.Posix
import           UnliftIO                 (throwIO, try)
import           Data.Maybe               (fromMaybe, isNothing)

import           Prelude

-- | The following example uses minio's play server at
-- https://play.min.io.  The endpoint and associated
-- credentials are provided via the libary constant,
--
-- > minioPlayCI :: ConnectInfo
--

-- optparse-applicative package based command-line parsing.
fileNameArgs :: Parser FilePath
fileNameArgs = strArgument
               (metavar "FILENAME"
                <> help "Name of file to upload to AWS S3 or a MinIO server")

cmdParser = info
            (helper <*> fileNameArgs)
            (fullDesc
             <> progDesc "FileUploader"
             <> header
             "FileUploader - a simple file-uploader program using minio-hs")

-- ObjStore Effect
data ObjStore m a where
  MakeTargetBucket :: Bucket -> ObjStore m ()
  UploadFile :: FilePath -> Bucket -> Object -> ObjStore m ()

makeSem ''ObjStore

data ObjectTest = ObjectTest
                  { otName :: Text
                  , otObject :: B.ByteString
                  }
                deriving (Show)

-- ObjStore Test interpretation using hashmap for storing objects
objStoreInTest :: Members '[Error MinioErr, Embed IO, State (HM.HashMap Bucket [ObjectTest])] r => Sem (ObjStore ': r) a -> Sem r a
objStoreInTest = interpret $ \case
  MakeTargetBucket b -> do
    objMap <- get
    if isNothing (HM.lookup b objMap)
      then do let objMap' = HM.insert b [] objMap
              put objMap'
      else throw (MErrService BucketAlreadyOwnedByYou)

  UploadFile fp b o -> do
    objMap <- get
    contents <- embed $ B.readFile fp
    let bucketVal = HM.lookupDefault [] b objMap
        objMap' = HM.insert b (ObjectTest o contents : bucketVal) objMap
    put objMap'

-- ObjStore interpretation in IO monad
objStoreInIO :: Members '[Embed IO, Error MinioErr] r => Sem (ObjStore ': r) a -> Sem (Input ConnectInfo : r) a
objStoreInIO = reinterpret $ \case
  UploadFile fp b o -> do
    connInfo <- input
    fromEither =<< (embed $ runMinio connInfo $
                    -- Upload filepath to bucket; object is derived from filepath.
                    fPutObject b o fp defaultPutObjectOptions)

  MakeTargetBucket b -> do
    connInfo <- input
    fromEither =<< (embed $ runMinio connInfo $
                    -- Make a bucket; catch bucket already exists exception if thrown.
                    makeBucket b Nothing)

-- Business logic
fileUpload :: Members '[Error MinioErr, ObjStore] r => FilePath -> Bucket -> Object -> Sem r ()
fileUpload fp bucket object = do
  makeTargetBucket bucket
    `catch`
    (\err -> case err :: MinioErr of
               MErrService BucketAlreadyOwnedByYou -> return ()
               otherErr -> throw otherErr)

  uploadFile fp bucket object
  -- To trigger BucketAlreadyOwnedByYou exception
  makeTargetBucket bucket

runOnPlay :: FilePath -> Bucket -> Object -> IO ()
runOnPlay filepath bucket object = do
  resE <- runM
          . runError
          . runInputConst minioPlayCI
          . objStoreInIO
          $ fileUpload filepath bucket object
  either (\err -> print err) print resE

runOnTest :: FilePath -> Bucket -> Object -> IO ()
runOnTest filepath bucket object = do
  (finalState, resE) <- runM
                        . runState (HM.empty :: HM.HashMap Bucket [ObjectTest])
                        . runError
                        . objStoreInTest
                        $ fileUpload filepath bucket object
  print ("finalState: " ++ show finalState)
  case resE :: Either MinioErr () of
    Left err -> print ("Failed: " ++ show err)
    Right res -> print ("result" ++ show res)

main :: IO ()
main = do
  let bucket = "my-bucket" :: Text

  -- Parse command line argument
  filepath <- execParser cmdParser
  let object = pack $ takeBaseName filepath

  -- Run fileUpload on play.minio.io object storage
  runOnPlay filepath bucket object

  -- Run fileUpload on a test object storage simulated using HashMap
  runOnTest filepath bucket object