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.Monoid ((<>))
  27 import Data.Swagger.SchemaOptions (SchemaOptions, fromAesonOptions)
  28 import Servant.Job.Utils (wellNamedSchema)
  29 import Text.Read (Read(..),readMaybe)
  30
  31
  32 -- | Aeson Options that remove the prefix from fields
  33 unPrefix :: String -> Options
  34 unPrefix prefix = defaultOptions
  35   { fieldLabelModifier = unCapitalize . dropPrefix prefix
  36   , omitNothingFields = True
  37   }
  38
  39 unPrefixUntagged :: String -> Options
  40 unPrefixUntagged prefix = (unPrefix prefix)
  41   { sumEncoding = UntaggedValue }
  42
  43 unPrefixSwagger :: String -> SchemaOptions
  44 unPrefixSwagger = fromAesonOptions . unPrefix
  45
  46 -- | Lower case leading character
  47 unCapitalize :: String -> String
  48 unCapitalize [] = []
  49 unCapitalize (c:cs) = toLower c : cs
  50 --unCapitalize cs = map toLower cs
  51
  52 -- | Remove given prefix
  53 dropPrefix :: String -> String -> String
  54 dropPrefix prefix input = go prefix input
  55   where
  56     go pre [] = error $ conStringual $ "prefix leftover: " <> pre
  57     go [] (c:cs) = c : cs
  58     go (p:preRest) (c:cRest)
  59       | p == c = go preRest cRest
  60       | otherwise = error $ conStringual $ "not equal: " <>  (p:preRest)  <> " " <> (c:cRest)
  61
  62     conStringual msg = "dropPrefix: " <> msg <> ". " <> prefix <> " " <> input
  63
  64 parseJSONFromString :: (Read a) => Value -> Parser a
  65 parseJSONFromString v = do
  66   numString <- parseJSON v
  67   case readMaybe (numString :: String) of
  68     Nothing -> fail $ "Invalid number for TransactionID: " ++ show v -- TODO error message too specific
  69     Just n -> return n