src/Gargantext/Core/Utils/Prefix.hs

   1 {-|
   2 Module      : Gargantext.Core.Utils.Prefix
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Here is a longer description of this module, containing some
  11 commentary with @some markup@.
  12 -}
  13
  14
  15 module Gargantext.Core.Utils.Prefix
  16   ( module Gargantext.Core.Utils.Prefix
  17   , wellNamedSchema
  18   ) where
  19
  20 import Prelude
  21
  22 import Data.Aeson (Value, defaultOptions, parseJSON)
  23 import Data.Aeson.TH (Options, fieldLabelModifier, omitNothingFields, sumEncoding, SumEncoding(UntaggedValue))
  24 import Data.Aeson.Types (Parser)
  25 import Data.Char (toLower)
  26 import Data.Swagger.SchemaOptions (SchemaOptions, fromAesonOptions)
  27 import Servant.Job.Utils (wellNamedSchema)
  28 import Text.Read (readMaybe)
  29
  30
  31 -- | Aeson Options that remove the prefix from fields
  32 unPrefix :: String -> Options
  33 unPrefix prefix = defaultOptions
  34   { fieldLabelModifier = unCapitalize . dropPrefix prefix
  35   , omitNothingFields = True
  36   }
  37
  38 unPrefixUntagged :: String -> Options
  39 unPrefixUntagged prefix = (unPrefix prefix)
  40   { sumEncoding = UntaggedValue }
  41
  42 unPrefixSwagger :: String -> SchemaOptions
  43 unPrefixSwagger = fromAesonOptions . unPrefix
  44
  45 -- | Lower case leading character
  46 unCapitalize :: String -> String
  47 unCapitalize [] = []
  48 unCapitalize (c:cs) = toLower c : cs
  49 --unCapitalize cs = map toLower cs
  50
  51 -- | Remove given prefix
  52 dropPrefix :: String -> String -> String
  53 dropPrefix prefix input = go prefix input
  54   where
  55     go pre [] = error $ conStringual $ "prefix leftover: " <> pre
  56     go [] (c:cs) = c : cs
  57     go (p:preRest) (c:cRest)
  58       | p == c = go preRest cRest
  59       | otherwise = error $ conStringual $ "not equal: " <>  (p:preRest)  <> " " <> (c:cRest)
  60
  61     conStringual msg = "dropPrefix: " <> msg <> ". " <> prefix <> " " <> input
  62
  63 parseJSONFromString :: (Read a) => Value -> Parser a
  64 parseJSONFromString v = do
  65   numString <- parseJSON v
  66   case readMaybe (numString :: String) of
  67     Nothing -> fail $ "Invalid number for TransactionID: " ++ show v -- TODO error message too specific
  68     Just n -> return n