Stability : experimental
Portability : POSIX
+TODO_1: qualitative tests (human)
+TODO_2: quantitative tests (coded)
-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-
module Gargantext.Prelude.Utils
where
+
+import Control.Exception
import Control.Lens (view)
-import Control.Monad.Reader (MonadReader)
-import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Random.Class (MonadRandom)
+import Control.Monad.Reader (MonadReader)
+import Data.Aeson (ToJSON, toJSON)
import Data.Text (Text)
-import Control.Monad.Reader (ask)
+import Data.Tuple.Extra (both)
import GHC.IO (FilePath)
+import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
+import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Prelude
-import Gargantext.API.Settings
+import Gargantext.Prelude.Config
+import Gargantext.Prelude.Crypto.Hash
+import System.Directory (createDirectoryIfMissing)
+import System.IO.Error
import System.Random (newStdGen)
+import qualified Data.Text as Text
+import qualified System.Directory as SD
import qualified System.Random.Shuffle as SRS
-import System.Directory (createDirectoryIfMissing)
-import qualified Data.ByteString.Lazy.Char8 as Char
-import qualified Data.Digest.Pure.SHA as SHA (sha256, showDigest)
-import qualified Data.Text as Text
-import Gargantext.Database.Types.Node (NodeId, NodeType)
-import Data.ByteString (ByteString)
-import Crypto.Argon2 as Crypto
-import Data.Either
-import Data.ByteString.Base64.URL as URL
---------------------------------------------------------------------------
-shuffle :: MonadRandom m => [a] -> m [a]
-shuffle ns = SRS.shuffleM ns
+-------------------------------------------------------------------
+-- | Main Class to use (just declare needed functions)
+class GargDB a where
+ write :: a -> IO ()
+ read :: FilePath -> IO a
---------------------------------------------------------------------------
-sha :: Text -> Text
-sha = Text.pack
- . SHA.showDigest
- . SHA.sha256
- . Char.pack
- . Text.unpack
+ rm :: (a, FilePath) -> IO ()
+ mv :: (a, FilePath) -> FilePath -> IO ()
---------------------------------------------------------------------------
-data NodeToHash = NodeToHash { nodeType :: NodeType
- , nodeId :: NodeId
- }
-secret_key :: ByteString
-secret_key = "WRV5ymit8s~ge6%08dLR7Q!gBcpb1MY%7e67db2206"
+-- | Why not this class too ?
+class ToJSON parameters => GargDB' parameters gargdata where
+ write' :: parameters -> gargdata -> IO ()
+ read' :: parameters -> IO gargdata
+
+ rm' :: gargdata -> parameters -> IO ()
+ mv' :: gargdata -> parameters -> parameters -> IO ()
+
+-------------------------------------------------------------------
+-- | Deprecated Class, use GargDB instead
+class SaveFile a where
+ saveFile' :: FilePath -> a -> IO ()
-type SecretKey = ByteString
+class ReadFile a where
+ readFile' :: FilePath -> IO a
+-------------------------------------------------------------------
+-------------------------------------------------------------------
+type GargFilePath = (FolderPath, FileName)
+-- where
type FolderPath = FilePath
type FileName = FilePath
-hashNode :: SecretKey -> NodeToHash -> ByteString
-hashNode sk (NodeToHash nt ni) = case hashResult of
- Left e -> panic (cs $ show e)
- Right h -> URL.encode h
- where
- hashResult = Crypto.hash Crypto.defaultHashOptions
- sk
- (cs $ show nt <> show ni)
+ --------------------------------
+dataFilePath :: (ToJSON a) => a -> GargFilePath
+dataFilePath = toPath . hash . show . toJSON
-toPath :: Int -> Text -> (FolderPath,FileName)
-toPath n x = (Text.unpack $ Text.intercalate "/" [x1,x2], Text.unpack xs)
- where
- (x1,x') = Text.splitAt n x
- (x2,xs) = Text.splitAt n x'
+randomFilePath :: ( MonadReader env m
+ , MonadBase IO m
+ )
+ => m GargFilePath
+randomFilePath = do
+ (foldPath, fileName) <- liftBase
+ $ toPath
+ . hash
+ . show
+ <$> newStdGen
+ pure (foldPath, fileName)
-class SaveFile a where
- saveFile' :: FilePath -> a -> IO ()
-class ReadFile a where
- readFile' :: FilePath -> IO a
+-- | toPath' : how to hash text to path
+{- example of use:
+>>> toPath' (1,2) ("","helloword")
+("/he","lloword")
+>>> toPath' (2,2) ("","helloword")
+("/he/ll","oword")
-writeFile :: (MonadReader env m, MonadIO m, HasSettings env, SaveFile a)
- => a -> m FilePath
+>>> toPath' (2,3) ("","helloword")
+("/hel/low","ord")
+-}
+toPath :: Text -> (FolderPath, FileName)
+toPath tx = both Text.unpack $ toPath' (2,3) ("", tx)
+
+toPath' :: (Int,Int) -> (Text,Text) -> (Text,Text)
+toPath' (n,m) (t,x) = foldl' (\tx _ -> toPath'' m tx) (t,x) [1..n]
+
+toPath'' :: Int -> (Text, Text) -> (Text, Text)
+toPath'' n (fp,fn) = (fp'',fn')
+ where
+ (fp',fn') = Text.splitAt n fn
+ fp'' = Text.intercalate "/" [fp,fp']
+
+-------------------------------------------------------------------
+type DataPath = FilePath
+toFilePath :: FilePath -> FilePath -> FilePath
+toFilePath fp1 fp2 = fp1 <> "/" <> fp2
+
+-------------------------------------------------------------------
+
+-- | Disk operations
+-- | For example, this write file with a random filepath
+-- better use a hash of json of Type used to parameter as input
+-- the functions
+writeFile :: ( MonadReader env m
+ , HasConfig env
+ , MonadBase IO m
+ , SaveFile a
+ )
+ => a -> m FilePath
writeFile a = do
- dataPath <- view (settings . fileFolder) <$> ask
- (fp,fn) <- liftIO $ (toPath 3) . sha . Text.pack . show <$> newStdGen
-
- let foldPath = dataPath <> "/" <> fp
- filePath = foldPath <> "/" <> fn
-
- _ <- liftIO $ createDirectoryIfMissing True foldPath
- _ <- liftIO $ saveFile' filePath a
-
+ dataPath <- view $ hasConfig . gc_datafilepath
+
+ (foldPath, fileName) <- randomFilePath
+
+ let filePath = toFilePath foldPath fileName
+ dataFoldPath = toFilePath dataPath foldPath
+ dataFileName = toFilePath dataPath filePath
+
+ _ <- liftBase $ createDirectoryIfMissing True dataFoldPath
+ _ <- liftBase $ saveFile' dataFileName a
+
pure filePath
+---
-readFile :: (MonadReader env m, MonadIO m, HasSettings env, ReadFile a)
+-- | Example to read a file with Type
+readFile :: ( MonadReader env m
+ , HasConfig env
+ , MonadBase IO m
+ , ReadFile a
+ )
=> FilePath -> m a
readFile fp = do
- dataPath <- view (settings . fileFolder) <$> ask
- liftIO $ readFile' $ dataPath <> "/" <> fp
+ dataPath <- view $ hasConfig . gc_datafilepath
+ liftBase $ readFile' $ toFilePath dataPath fp
+
+---
+
+rmFile :: ( MonadReader env m
+ , MonadBase IO m
+ , HasConfig env
+ )
+ => FilePath -> m ()
+rmFile = onDisk_1 SD.removeFile
+
+cpFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
+ => FilePath -> FilePath -> m ()
+cpFile = onDisk_2 SD.copyFile
+
+---
+
+mvFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
+ => FilePath -> FilePath -> m ()
+mvFile fp1 fp2 = do
+ cpFile fp1 fp2
+ rmFile fp1
+ pure ()
+
+------------------------------------------------------------------------
+onDisk_1 :: ( MonadReader env m
+ , MonadBase IO m
+ , HasConfig env
+ )
+ => (FilePath -> IO ()) -> FilePath -> m ()
+onDisk_1 action fp = do
+ dataPath <- view $ hasConfig . gc_datafilepath
+ liftBase $ action (toFilePath dataPath fp) `catch` handleExists
+ where
+ handleExists e
+ | isDoesNotExistError e = return ()
+ | otherwise = throwIO e
+
+
+onDisk_2 :: ( MonadReader env m
+ , MonadBase IO m
+ , HasConfig env
+ )
+ => (FilePath -> FilePath -> IO ())
+ -> FilePath
+ -> FilePath
+ -> m ()
+onDisk_2 action fp1 fp2 = do
+ dataPath <- view $ hasConfig . gc_datafilepath
+ let fp1' = toFilePath dataPath fp1
+ fp2' = toFilePath dataPath fp2
+ liftBase $ action fp1' fp2' `catch` handleExists
+ where
+ handleExists e
+ | isDoesNotExistError e = return ()
+ | otherwise = throwIO e
+------------------------------------------------------------------------
+
+------------------------------------------------------------------------
+-- | Misc Utils
+shuffle :: MonadRandom m => [a] -> m [a]
+shuffle ns = SRS.shuffleM ns
+--------------------------------------------------------------------------
+
+-- TODO gargDB instance for NodeType
+data NodeToHash = NodeToHash { nodeType :: NodeType
+ , nodeId :: NodeId
+ }
+