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 {-# LANGUAGE     FlexibleContexts        #-}
  13 {-# LANGUAGE     NoImplicitPrelude       #-}
  14 {-# LANGUAGE     OverloadedStrings       #-}
  15
  16 module Gargantext.Prelude.Utils
  17   where
  18
  19 import Control.Lens (view)
  20 import Control.Monad.Random.Class (MonadRandom)
  21 import Control.Monad.Reader (MonadReader)
  22 import Control.Monad.Reader (ask)
  23 import Crypto.Argon2 as Crypto
  24 import Data.ByteString (ByteString)
  25 import Data.ByteString.Base64.URL as URL
  26 import Data.Either
  27 import Data.Text (Text)
  28 import GHC.IO (FilePath)
  29 import Gargantext.API.Admin.Settings
  30 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
  31 import Gargantext.Prelude
  32 import System.Directory (createDirectoryIfMissing)
  33 import System.Random (newStdGen)
  34 import qualified Data.ByteString.Lazy.Char8  as Char
  35 import qualified Data.Digest.Pure.SHA        as SHA (sha256, showDigest)
  36 import qualified Data.Text                   as Text
  37 import qualified System.Random.Shuffle as SRS
  38
  39 --------------------------------------------------------------------------
  40 shuffle :: MonadRandom m => [a] -> m [a]
  41 shuffle ns = SRS.shuffleM ns
  42
  43 --------------------------------------------------------------------------
  44 sha :: Text -> Text
  45 sha = Text.pack
  46      . SHA.showDigest
  47      . SHA.sha256
  48      . Char.pack
  49      . Text.unpack
  50
  51 --------------------------------------------------------------------------
  52 data NodeToHash = NodeToHash { nodeType :: NodeType
  53                              , nodeId   :: NodeId
  54                              }
  55
  56 secret_key :: ByteString
  57 secret_key = "WRV5ymit8s~ge6%08dLR7Q!gBcpb1MY%7e67db2206"
  58
  59 type SecretKey = ByteString
  60
  61 type FolderPath = FilePath
  62 type FileName   = FilePath
  63
  64 hashNode :: SecretKey -> NodeToHash -> ByteString
  65 hashNode sk (NodeToHash nt ni) = case hashResult of
  66     Left  e -> panic (cs $ show e)
  67     Right h -> URL.encode h
  68   where
  69     hashResult = Crypto.hash Crypto.defaultHashOptions
  70                   sk
  71                   (cs $ show nt <> show ni)
  72
  73
  74 toPath :: Int -> Text -> (FolderPath,FileName)
  75 toPath n x = (Text.unpack $ Text.intercalate "/" [x1,x2], Text.unpack xs)
  76   where
  77     (x1,x') = Text.splitAt n x
  78     (x2,xs) = Text.splitAt n x'
  79
  80 class SaveFile a where
  81   saveFile' :: FilePath -> a -> IO ()
  82
  83 class ReadFile a where
  84   readFile' :: FilePath -> IO a
  85
  86
  87 writeFile :: (MonadReader env m, MonadBase IO m, HasSettings env, SaveFile a)
  88          => a -> m FilePath
  89 writeFile a = do
  90   dataPath <- view (settings . fileFolder) <$> ask
  91   (fp,fn)  <- liftBase $ (toPath 3) . sha . Text.pack . show <$> newStdGen
  92
  93   let foldPath = dataPath <> "/" <> fp
  94       filePath = foldPath <> "/" <> fn
  95
  96   _ <- liftBase $ createDirectoryIfMissing True foldPath
  97   _ <- liftBase $ saveFile' filePath a
  98
  99   pure filePath
 100
 101
 102 readFile :: (MonadReader env m, MonadBase IO m, HasSettings env, ReadFile a)
 103          => FilePath -> m a
 104 readFile fp = do
 105   dataPath <- view (settings . fileFolder) <$> ask
 106   liftBase $ readFile' $ dataPath <> "/" <> fp