src/Gargantext/Prelude/Utils.hs

   1 {-|
   2 Module      : Gargantext.Prelude.Utils
   3 Description : Useful Tools near Prelude of the project
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12
  13 module Gargantext.Prelude.Utils
  14   where
  15
  16 import Control.Lens (view)
  17 import Control.Monad.Random.Class (MonadRandom)
  18 import Control.Monad.Reader (MonadReader)
  19 import Control.Monad.Reader (ask)
  20 import Data.Text (Text)
  21 import GHC.IO (FilePath)
  22 import Gargantext.API.Admin.Settings
  23 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
  24 import Gargantext.Prelude
  25 import System.Directory (createDirectoryIfMissing)
  26 import System.Random (newStdGen)
  27 import qualified Data.ByteString.Lazy.Char8  as Char
  28 import qualified Data.Digest.Pure.SHA        as SHA (sha256, showDigest)
  29 import qualified Data.Text                   as Text
  30 import qualified System.Random.Shuffle as SRS
  31
  32 --------------------------------------------------------------------------
  33 shuffle :: MonadRandom m => [a] -> m [a]
  34 shuffle ns = SRS.shuffleM ns
  35
  36 --------------------------------------------------------------------------
  37 sha :: Text -> Text
  38 sha = Text.pack
  39      . SHA.showDigest
  40      . SHA.sha256
  41      . Char.pack
  42      . Text.unpack
  43
  44 --------------------------------------------------------------------------
  45 data NodeToHash = NodeToHash { nodeType :: NodeType
  46                              , nodeId   :: NodeId
  47                              }
  48
  49 type FolderPath = FilePath
  50 type FileName   = FilePath
  51
  52 toPath :: Int -> Text -> (FolderPath,FileName)
  53 toPath n x = (Text.unpack $ Text.intercalate "/" [x1,x2], Text.unpack xs)
  54   where
  55     (x1,x') = Text.splitAt n x
  56     (x2,xs) = Text.splitAt n x'
  57
  58 class SaveFile a where
  59   saveFile' :: FilePath -> a -> IO ()
  60
  61 class ReadFile a where
  62   readFile' :: FilePath -> IO a
  63
  64
  65 writeFile :: (MonadReader env m, MonadBase IO m, HasSettings env, SaveFile a)
  66          => a -> m FilePath
  67 writeFile a = do
  68   dataPath <- view (settings . fileFolder) <$> ask
  69   (fp,fn)  <- liftBase $ (toPath 3) . sha . Text.pack . show <$> newStdGen
  70
  71   let foldPath = dataPath <> "/" <> fp
  72       filePath = foldPath <> "/" <> fn
  73
  74   _ <- liftBase $ createDirectoryIfMissing True foldPath
  75   _ <- liftBase $ saveFile' filePath a
  76
  77   pure filePath
  78
  79
  80 readFile :: (MonadReader env m, MonadBase IO m, HasSettings env, ReadFile a)
  81          => FilePath -> m a
  82 readFile fp = do
  83   dataPath <- view (settings . fileFolder) <$> ask
  84   liftBase $ readFile' $ dataPath <> "/" <> fp