src/Gargantext/Core/NLP.hs

   1 module Gargantext.Core.NLP where
   2
   3 import Control.Lens (Getter, at, non)
   4 import qualified Data.Map.Strict as Map
   5 import Data.Maybe (fromJust)
   6 import Network.URI (URI(..), parseURI)
   7 import Gargantext.Core (Lang(..), NLPServerConfig(..), PosTagAlgo(..), allLangs)
   8 import Gargantext.Prelude.NLP.Types (NLPConfig(..))
   9 import Gargantext.Utils.Tuple (uncurryMaybeSecond)
  10 import Protolude hiding (All)
  11
  12
  13 type NLPServerMap = Map.Map Lang NLPServerConfig
  14
  15 class HasNLPServer env where
  16   nlpServer :: Getter env NLPServerMap
  17   nlpServerGet :: Lang -> Getter env NLPServerConfig
  18   -- default implementation
  19   nlpServerGet l = nlpServer . at l . non defaultNLPServer
  20
  21 defaultNLPServer :: NLPServerConfig
  22 defaultNLPServer = NLPServerConfig { server = CoreNLP
  23                                    , url = fromJust $ parseURI "http://localhost:9000"
  24                                    }
  25
  26 nlpServerConfigFromURI :: URI -> Maybe NLPServerConfig
  27 nlpServerConfigFromURI uri@(URI { uriScheme = "corenlp:" }) =
  28   Just $ NLPServerConfig { server = CoreNLP
  29                          , url = uri { uriScheme = "http:" }
  30                          }
  31 nlpServerConfigFromURI uri@(URI { uriScheme = "corenlps:" }) =
  32   Just $ NLPServerConfig { server = CoreNLP
  33                          , url = uri { uriScheme = "https:" }
  34                          }
  35 nlpServerConfigFromURI uri@(URI { uriScheme = "johnsnow:" }) =
  36   Just $ NLPServerConfig { server = JohnSnowServer
  37                          , url = uri { uriScheme = "http:" }
  38                          }
  39 nlpServerConfigFromURI uri@(URI { uriScheme = "johnsnows:" }) =
  40   Just $ NLPServerConfig { server = JohnSnowServer
  41                          , url = uri { uriScheme = "https:" }
  42                          }
  43 nlpServerConfigFromURI uri@(URI { uriScheme = "spacy:" }) =
  44   Just $ NLPServerConfig { server = Spacy
  45                          , url = uri { uriScheme = "http:" }
  46                          }
  47 nlpServerConfigFromURI uri@(URI { uriScheme = "spacys:" }) =
  48   Just $ NLPServerConfig { server = Spacy
  49                          , url = uri { uriScheme = "https:" }
  50                          }
  51 nlpServerConfigFromURI _ = Nothing
  52
  53
  54 nlpServerMap :: NLPConfig -> NLPServerMap
  55 nlpServerMap (NLPConfig { .. }) =
  56   Map.fromList $ catMaybes $
  57     [ uncurryMaybeSecond (All, nlpServerConfigFromURI _nlp_all) ] ++
  58     ((\lang ->
  59         uncurryMaybeSecond (lang, Map.lookup (show lang) _nlp_languages >>= nlpServerConfigFromURI ))
  60       <$> allLangs)