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 {-# OPTIONS_GHC -fno-warn-orphans   #-}
  13
  14 module Gargantext.Prelude.Utils
  15   where
  16
  17 import Prelude (String)
  18 import Data.Set (Set)
  19 import Data.List (foldl)
  20 import Control.Lens (view)
  21 import Control.Monad.Random.Class (MonadRandom)
  22 import Control.Monad.Reader (MonadReader)
  23 import Control.Monad.Reader (ask)
  24 import Data.Text (Text)
  25 import GHC.IO (FilePath)
  26 import Gargantext.API.Admin.Settings
  27 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
  28 import Gargantext.Prelude
  29 import System.Directory (createDirectoryIfMissing)
  30 import System.Random (newStdGen)
  31 import qualified Data.ByteString.Lazy.Char8  as Char
  32 import qualified Data.Digest.Pure.SHA        as SHA (sha256, showDigest)
  33 import qualified Data.Set                    as Set
  34 import qualified Data.Text                   as Text
  35 import qualified System.Random.Shuffle as SRS
  36
  37 --------------------------------------------------------------------------
  38 shuffle :: MonadRandom m => [a] -> m [a]
  39 shuffle ns = SRS.shuffleM ns
  40
  41 --------------------------------------------------------------------------
  42 -- | Use this datatype to keep traceability of hashes
  43 -- TODO use newtype
  44 type Hash = Text
  45
  46 -- | Class to make hashes
  47 class IsHashable a where
  48   hash :: a -> Hash
  49
  50 -- | Main API to hash text
  51 -- using sha256 for now
  52 instance IsHashable Char.ByteString where
  53   hash = Text.pack
  54         . SHA.showDigest
  55         . SHA.sha256
  56
  57 instance {-# OVERLAPPING #-} IsHashable String where
  58   hash = hash . Char.pack
  59
  60 instance IsHashable Text where
  61   hash = hash . Text.unpack
  62
  63 instance IsHashable (Set Hash) where
  64   hash = hash . foldl (<>) "" . Set.toList
  65
  66 instance {-# OVERLAPPABLE #-} IsHashable a => IsHashable [a] where
  67   hash = hash . Set.fromList . map hash
  68
  69 --------------------------------------------------------------------------
  70 data NodeToHash = NodeToHash { nodeType :: NodeType
  71                              , nodeId   :: NodeId
  72                              }
  73
  74 type FolderPath = FilePath
  75 type FileName   = FilePath
  76
  77 toPath :: Int -> Text -> (FolderPath,FileName)
  78 toPath n x = (Text.unpack $ Text.intercalate "/" [x1,x2], Text.unpack xs)
  79   where
  80     (x1,x') = Text.splitAt n x
  81     (x2,xs) = Text.splitAt n x'
  82
  83 class SaveFile a where
  84   saveFile' :: FilePath -> a -> IO ()
  85
  86 class ReadFile a where
  87   readFile' :: FilePath -> IO a
  88
  89
  90 writeFile :: (MonadReader env m, MonadBase IO m, HasSettings env, SaveFile a)
  91          => a -> m FilePath
  92 writeFile a = do
  93   dataPath <- view (settings . fileFolder) <$> ask
  94   (fp,fn)  <- liftBase $ (toPath 3) . hash . show <$> newStdGen
  95
  96   let foldPath = dataPath <> "/" <> fp
  97       filePath = foldPath <> "/" <> fn
  98
  99   _ <- liftBase $ createDirectoryIfMissing True foldPath
 100   _ <- liftBase $ saveFile' filePath a
 101
 102   pure filePath
 103
 104
 105 readFile :: (MonadReader env m, MonadBase IO m, HasSettings env, ReadFile a)
 106          => FilePath -> m a
 107 readFile fp = do
 108   dataPath <- view (settings . fileFolder) <$> ask
 109   liftBase $ readFile' $ dataPath <> "/" <> fp