Skip to content

H
haskell-gargantext-prelude
Commit 9dc45d72 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FIX] compilation ok

parent 4310ef62
Hide whitespace changes
Inline Side-by-side
Showing with 168 additions and 278 deletions
app/Main.hs
View file @ 9dc45d72
module Main where
import Lib
import Protolude
main :: IO ()
main = someFunc
main = undefined
gargantext-prelude.cabal
View file @ 9dc45d72
......@@ -4,17 +4,17 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 4f8c4d6e24334ff69c434fceb4fc7135a3aec9926a3e99a1b0a85df27eb6fba1
-- hash: 6e48706c178c8a0ee4f59e1fb5299dd49cee97a6284b076799aed4905fc8e3f8
name: gargantext-prelude
version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/githubuser/gargantext-prelude#readme>
homepage: https://github.com/githubuser/gargantext-prelude#readme
bug-reports: https://github.com/githubuser/gargantext-prelude/issues
author: Author name here
maintainer: example@example.com
copyright: 2021 Author name here
license: BSD3
author: Team Hello Word / CNRS
maintainer: team@gargantext.org
copyright: 2021 HW/CNRS/Alexandre Delanoë
license: AGPL-3
license-file: LICENSE
build-type: Simple
extra-source-files:
......@@ -27,13 +27,53 @@ source-repository head
library
exposed-modules:
Lib
Gargantext.Prelude
Gargantext.Prelude.Clock
Gargantext.Prelude.Config
Gargantext.Prelude.Crypto.Auth
Gargantext.Prelude.Crypto.Hash
Gargantext.Prelude.Crypto.Pass.Machine
Gargantext.Prelude.Crypto.Pass.User
Gargantext.Prelude.Crypto.Share
Gargantext.Prelude.Fibonacci
Gargantext.Prelude.Mail
Gargantext.Prelude.Utils
other-modules:
Paths_gargantext_prelude
hs-source-dirs:
src
default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes
build-depends:
base >=4.7 && <5
MonadRandom
, SHA
, aeson
, base >=4.7 && <5
, binary
, bytestring
, clock
, containers
, cprng-aes
, crypto-random
, directory
, extra
, filepath
, formatting
, ini
, lens
, located-base
, mime-mail
, mtl
, password
, protolude
, random
, random-shuffle
, safe
, smtp-mail
, string-conversions
, text
, transformers
, transformers-base
, vector
default-language: Haskell2010
executable gargantext-prelude-exe
......@@ -42,10 +82,40 @@ executable gargantext-prelude-exe
Paths_gargantext_prelude
hs-source-dirs:
app
default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
MonadRandom
, SHA
, aeson
, base >=4.7 && <5
, binary
, bytestring
, clock
, containers
, cprng-aes
, crypto-random
, directory
, extra
, filepath
, formatting
, gargantext-prelude
, ini
, lens
, located-base
, mime-mail
, mtl
, password
, protolude
, random
, random-shuffle
, safe
, smtp-mail
, string-conversions
, text
, transformers
, transformers-base
, vector
default-language: Haskell2010
test-suite gargantext-prelude-test
......@@ -55,8 +125,38 @@ test-suite gargantext-prelude-test
Paths_gargantext_prelude
hs-source-dirs:
test
default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NoImplicitPrelude OverloadedStrings RankNTypes
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
MonadRandom
, SHA
, aeson
, base >=4.7 && <5
, binary
, bytestring
, clock
, containers
, cprng-aes
, crypto-random
, directory
, extra
, filepath
, formatting
, gargantext-prelude
, ini
, lens
, located-base
, mime-mail
, mtl
, password
, protolude
, random
, random-shuffle
, safe
, smtp-mail
, string-conversions
, text
, transformers
, transformers-base
, vector
default-language: Haskell2010
package.yaml
View file @ 9dc45d72
name: gargantext-prelude
version: 0.1.0.0
github: "githubuser/gargantext-prelude"
license: GarganText like CNRS.LL
license: AGPL-3
author: "Team Hello Word / CNRS"
maintainer: "team@gargantext.org"
copyright: "2021 HW/CNRS/Alexandre Delanoë"
......@@ -20,8 +20,47 @@ extra-source-files:
description: Please see the README on GitHub at <https://github.com/githubuser/gargantext-prelude#readme>
dependencies:
- SHA
- aeson
- base >= 4.7 && < 5
- binary
- bytestring
- clock
- containers
- cprng-aes
- crypto-random
- directory
- extra
- filepath
- formatting
- ini
- lens
- located-base
- mtl
- password
- protolude
- random
- safe
- mime-mail
- smtp-mail
- string-conversions
- MonadRandom
- random-shuffle
- text
- transformers
- transformers-base
- vector
default-extensions:
- DataKinds
- DeriveGeneric
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- MultiParamTypeClasses
- NoImplicitPrelude
- OverloadedStrings
- RankNTypes
library:
source-dirs: src
......
src/Gargantext/Prelude.hs
View file @ 9dc45d72
......@@ -12,6 +12,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Gargantext.Prelude
( module Gargantext.Prelude
, module Protolude
......
src/Gargantext/Prelude/Crypto/Share.hs
View file @ 9dc45d72
......@@ -28,8 +28,7 @@ module Gargantext.Prelude.Crypto.Share
import Data.Maybe
import System.Random
import Prelude (fromEnum, toEnum)
import Gargantext.Core.Types (Ordering)
import Prelude (fromEnum, toEnum, String)
import Gargantext.Prelude
------------------------------------------------------------------------
......@@ -38,11 +37,19 @@ newtype Seed = Seed Int
type Private = Seed
type Public = Seed
data Ordering = Down | Up
deriving (Enum, Show, Eq, Bounded)
------------------------------------------------------------------------
createSeed :: String -> (Char -> Int) -> Seed
createSeed = undefined
------------------------------------------------------------------------
instance Random Ordering where
randomR (a, b) g =
......@@ -57,6 +64,10 @@ randomOrdering = randomWith
randomBool :: Maybe Seed -> Int -> IO [Bool]
randomBool= randomWith
randomDouble :: Maybe Seed -> Int -> IO [Double]
randomDouble = randomWith
------------------------------------------------------------------
randomWith :: Random a => Maybe Seed -> Int -> IO [a]
......
src/Gargantext/Prelude/GargDB.hs deleted 100644 → 0
View file @ 4310ef62
{-|
Module : Gargantext.Prelude.GargDB
Description : Useful Tools near Prelude of the project
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
TODO_1: qualitative tests (human)
TODO_2: quantitative tests (coded)
-}
module Gargantext.Prelude.GargDB
where
import Control.Exception
import Control.Lens (view)
import Control.Monad.Reader (MonadReader)
import Data.Aeson (ToJSON, toJSON)
import Data.Text (Text)
import Data.Tuple.Extra (both)
import GHC.IO (FilePath)
import Gargantext.Database.Prelude (HasConfig(..))
import Gargantext.Prelude
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
-------------------------------------------------------------------
-- | Main Class to use (just declare needed functions)
class GargDB a where
write :: a -> IO ()
read :: FilePath -> IO a
rm :: (a, FilePath) -> IO ()
mv :: (a, FilePath) -> FilePath -> IO ()
-- | 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 ()
class ReadFile a where
readFile' :: FilePath -> IO a
-------------------------------------------------------------------
-------------------------------------------------------------------
type GargFilePath = (FolderPath, FileName)
-- where
type FolderPath = FilePath
type FileName = FilePath
--------------------------------
dataFilePath :: (ToJSON a) => a -> GargFilePath
dataFilePath = toPath . hash . show . toJSON
randomFilePath :: ( MonadReader env m
, MonadBase IO m
)
=> m GargFilePath
randomFilePath = do
(foldPath, fileName) <- liftBase
$ toPath
. hash
. show
<$> newStdGen
pure (foldPath, fileName)
-- | toPath' : how to hash text to path
{- example of use:
>>> toPath' (1,2) ("","helloword")
("/he","lloword")
>>> toPath' (2,2) ("","helloword")
("/he/ll","oword")
>>> 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 $ 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
---
-- | 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 $ 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
------------------------------------------------------------------------
src/Gargantext/Prelude/Job.hs deleted 100644 → 0
View file @ 4310ef62
module Gargantext.Prelude.Job where
import Data.IORef
import Data.Maybe
import Gargantext.Prelude
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
jobLogInit :: Int -> JobLog
jobLogInit rem =
JobLog { _scst_succeeded = Just 0
, _scst_remaining = Just rem
, _scst_failed = Just 0
, _scst_events = Just [] }
jobLogSuccess :: JobLog -> JobLog
jobLogSuccess (JobLog { _scst_succeeded = mSucc
, _scst_remaining = mRem
, _scst_failed = mFail
, _scst_events = evt }) =
JobLog { _scst_succeeded = (+ 1) <$> mSucc
, _scst_remaining = (\x -> x - 1) <$> mRem
, _scst_failed = mFail
, _scst_events = evt }
jobLogFail :: JobLog -> JobLog
jobLogFail (JobLog { _scst_succeeded = mSucc
, _scst_remaining = mRem
, _scst_failed = mFail
, _scst_events = evt }) =
JobLog { _scst_succeeded = mSucc
, _scst_remaining = (\x -> x - 1) <$> mRem
, _scst_failed = (+ 1) <$> mFail
, _scst_events = evt }
runJobLog :: MonadBase IO m => Int -> (JobLog -> m ()) -> m (m (), m (), m JobLog)
runJobLog num logStatus = do
jlRef <- liftBase $ newIORef $ jobLogInit num
return (logRefF jlRef, logRefSuccessF jlRef, getRefF jlRef)
where
logRefF ref = do
jl <- liftBase $ readIORef ref
logStatus jl
logRefSuccessF ref = do
jl <- liftBase $ readIORef ref
let jl' = jobLogSuccess jl
liftBase $ writeIORef ref jl'
logStatus jl'
getRefF ref = do
liftBase $ readIORef ref
stack.yaml
View file @ 9dc45d72
......@@ -31,6 +31,7 @@ resolver:
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
......@@ -40,7 +41,8 @@ packages:
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
extra-deps:
- located-base-0.1.1.1@sha256:7c6395f2b6fbf2d5f76c3514f774423838c0ea94e1c6a5530dd3c94b30c9d1c8,1904
# Override default flag values for local packages and extra-deps
# flags: {}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment