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 TODO_1: qualitative  tests (human)
  11 TODO_2: quantitative tests (coded)
  12
  13
  14 -}
  15
  16 module Gargantext.Prelude.Utils
  17   where
  18
  19 import Control.Exception
  20 import Control.Lens (view)
  21 import Control.Monad.Random.Class (MonadRandom)
  22 import Control.Monad.Reader (MonadReader)
  23 import Data.Aeson (ToJSON, toJSON)
  24 import Data.Text (Text)
  25 import Data.Tuple.Extra (both)
  26 import Formatting.Clock (timeSpecs)
  27 import Formatting.Internal (Format(..))
  28 import GHC.IO (FilePath)
  29 import Gargantext.Database.Admin.Types.Node (NodeId, NodeType)
  30 import Gargantext.Database.Prelude (HasConfig(..))
  31 import Gargantext.Prelude
  32 import Gargantext.Prelude.Config
  33 import Gargantext.Prelude.Crypto.Hash
  34 import System.Directory (createDirectoryIfMissing)
  35 import System.IO.Error
  36 import System.Random (newStdGen)
  37 import qualified Data.Text             as Text
  38 import qualified System.Clock          as Clock (getTime, TimeSpec, Clock(..))
  39 import qualified System.Directory      as SD
  40 import qualified System.Random.Shuffle as SRS
  41
  42 -------------------------------------------------------------------
  43 hasTime :: Formatting.Internal.Format r (Clock.TimeSpec -> Clock.TimeSpec -> r)
  44 hasTime = timeSpecs
  45
  46 getTime :: MonadBase IO m => m Clock.TimeSpec
  47 getTime = liftBase $ Clock.getTime Clock.ProcessCPUTime
  48 -------------------------------------------------------------------
  49 -- | Main Class to use (just declare needed functions)
  50 class GargDB a where
  51   write :: a        -> IO ()
  52   read  :: FilePath -> IO a
  53
  54   rm    :: (a, FilePath) -> IO ()
  55   mv    :: (a, FilePath) -> FilePath -> IO ()
  56
  57
  58 -- | Why not this class too ?
  59 class ToJSON parameters => GargDB' parameters gargdata where
  60   write' :: parameters -> gargdata -> IO ()
  61   read'  :: parameters -> IO gargdata
  62
  63   rm'    :: gargdata -> parameters -> IO ()
  64   mv'    :: gargdata -> parameters -> parameters -> IO ()
  65
  66 -------------------------------------------------------------------
  67 -- | Deprecated Class, use GargDB instead
  68 class SaveFile a where
  69   saveFile' :: FilePath -> a -> IO ()
  70
  71 class ReadFile a where
  72   readFile' :: FilePath -> IO a
  73
  74 -------------------------------------------------------------------
  75 -------------------------------------------------------------------
  76 type GargFilePath = (FolderPath, FileName)
  77 -- where
  78 type FolderPath = FilePath
  79 type FileName   = FilePath
  80
  81            --------------------------------
  82
  83 dataFilePath :: (ToJSON a) => a -> GargFilePath
  84 dataFilePath = toPath . hash . show . toJSON
  85
  86 randomFilePath :: ( MonadReader  env m
  87                   , MonadBase IO     m
  88                   )
  89                => m GargFilePath
  90 randomFilePath = do
  91   (foldPath, fileName)  <- liftBase
  92                          $ toPath
  93                          . hash
  94                          . show
  95                          <$> newStdGen
  96   pure (foldPath, fileName)
  97
  98
  99 -- | toPath' : how to hash text to path
 100 {- example of use:
 101 >>> toPath' (1,2) ("","helloword")
 102 ("/he","lloword")
 103
 104 >>> toPath' (2,2) ("","helloword")
 105 ("/he/ll","oword")
 106
 107 >>> toPath' (2,3) ("","helloword")
 108 ("/hel/low","ord")
 109 -}
 110 toPath :: Text -> (FolderPath, FileName)
 111 toPath tx = both Text.unpack $ toPath' (2,3) ("", tx)
 112
 113 toPath' :: (Int,Int) -> (Text,Text) -> (Text,Text)
 114 toPath' (n,m) (t,x) = foldl' (\tx _ -> toPath'' m tx) (t,x) [1..n]
 115
 116 toPath'' :: Int -> (Text, Text) -> (Text, Text)
 117 toPath'' n (fp,fn) = (fp'',fn')
 118   where
 119     (fp',fn') = Text.splitAt n fn
 120     fp''      = Text.intercalate "/" [fp,fp']
 121
 122 -------------------------------------------------------------------
 123 type DataPath   = FilePath
 124 toFilePath :: FilePath -> FilePath -> FilePath
 125 toFilePath fp1 fp2 = fp1 <> "/" <> fp2
 126
 127 -------------------------------------------------------------------
 128
 129 -- | Disk operations
 130 -- | For example, this write file with a random filepath
 131 -- better use a hash of json of Type used to parameter as input
 132 -- the functions
 133 writeFile :: ( MonadReader env m
 134              , HasConfig   env
 135              , MonadBase IO    m
 136              , SaveFile        a
 137              )
 138           => a -> m FilePath
 139 writeFile a = do
 140   dataPath <- view $ hasConfig . gc_datafilepath
 141
 142   (foldPath, fileName) <- randomFilePath
 143
 144   let filePath     = toFilePath foldPath fileName
 145       dataFoldPath = toFilePath dataPath foldPath
 146       dataFileName = toFilePath dataPath filePath
 147
 148   _ <- liftBase $ createDirectoryIfMissing True dataFoldPath
 149   _ <- liftBase $ saveFile' dataFileName a
 150
 151   pure filePath
 152
 153 ---
 154
 155 -- | Example to read a file with Type
 156 readFile :: ( MonadReader  env m
 157             , HasConfig    env
 158             , MonadBase IO     m
 159             , ReadFile         a
 160             )
 161          => FilePath -> m a
 162 readFile fp = do
 163   dataPath <- view $ hasConfig . gc_datafilepath
 164   liftBase $ readFile' $ toFilePath dataPath fp
 165
 166 ---
 167
 168 rmFile :: ( MonadReader env m
 169               , MonadBase IO m
 170               , HasConfig env
 171               )
 172            => FilePath -> m ()
 173 rmFile = onDisk_1 SD.removeFile
 174
 175 cpFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
 176            => FilePath -> FilePath -> m ()
 177 cpFile = onDisk_2 SD.copyFile
 178
 179 ---
 180
 181 mvFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
 182        => FilePath -> FilePath -> m ()
 183 mvFile fp1 fp2 = do
 184   cpFile fp1 fp2
 185   rmFile fp1
 186   pure ()
 187
 188 ------------------------------------------------------------------------
 189 onDisk_1 :: ( MonadReader env m
 190               , MonadBase IO m
 191               , HasConfig env
 192               )
 193         => (FilePath -> IO ()) -> FilePath -> m ()
 194 onDisk_1 action fp = do
 195   dataPath <- view $ hasConfig . gc_datafilepath
 196   liftBase $ action (toFilePath dataPath fp) `catch` handleExists
 197     where
 198       handleExists e
 199         | isDoesNotExistError e = return ()
 200         | otherwise = throwIO e
 201
 202
 203 onDisk_2 :: ( MonadReader env m
 204               , MonadBase IO m
 205               , HasConfig env
 206               )
 207         => (FilePath -> FilePath -> IO ())
 208         -> FilePath
 209         -> FilePath
 210         -> m ()
 211 onDisk_2 action fp1 fp2 = do
 212   dataPath <- view $ hasConfig . gc_datafilepath
 213   let fp1' = toFilePath dataPath fp1
 214       fp2' = toFilePath dataPath fp2
 215   liftBase $ action fp1' fp2' `catch` handleExists
 216     where
 217       handleExists e
 218         | isDoesNotExistError e = return ()
 219         | otherwise = throwIO e
 220 ------------------------------------------------------------------------
 221
 222 ------------------------------------------------------------------------
 223 -- | Misc Utils
 224 shuffle :: MonadRandom m => [a] -> m [a]
 225 shuffle ns = SRS.shuffleM ns
 226 --------------------------------------------------------------------------
 227
 228 -- TODO gargDB instance for NodeType
 229 data NodeToHash = NodeToHash { nodeType :: NodeType
 230                              , nodeId   :: NodeId
 231                              }
 232