src/Gargantext/API.hs

   1 {-|
   2 Module      : Gargantext.API
   3 Description : REST API declaration
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Main (RESTful) API of the instance Gargantext.
  11
  12 The Garg-API is typed to derive the documentation, the mock and tests.
  13
  14 This API is indeed typed in order to be able to derive both the server
  15 and the client sides.
  16
  17 The Garg-API-Monad enables:
  18   - Security (WIP)
  19   - Features (WIP)
  20   - Database connection (long term)
  21   - In Memory stack management (short term)
  22   - Logs (WIP)
  23
  24 Thanks to Yann Esposito for our discussions at the start and to Nicolas
  25 Pouillard (who mainly made it).
  26
  27 -}
  28
  29 {-# LANGUAGE ScopedTypeVariables  #-}
  30 {-# LANGUAGE TypeOperators        #-}
  31 module Gargantext.API
  32       where
  33
  34 import Control.Exception (finally)
  35 import Control.Lens
  36 import Control.Monad.Reader (runReaderT)
  37 import Data.List (lookup)
  38 import Data.Text.Encoding (encodeUtf8)
  39 import Data.Text.IO (putStrLn)
  40 import Data.Validity
  41 import GHC.Base (Applicative)
  42 import GHC.Generics (Generic)
  43 import Gargantext.API.Admin.Auth.Types (AuthContext)
  44 import Gargantext.API.Admin.Settings (newEnv)
  45 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
  46 import Gargantext.API.EKG
  47 import Gargantext.API.Ngrams (saveNodeStory)
  48 import Gargantext.API.Prelude
  49 import Gargantext.API.Routes
  50 import Gargantext.API.Server (server)
  51 import Gargantext.Core.NodeStory
  52 import Gargantext.Prelude hiding (putStrLn)
  53 import Network.HTTP.Types hiding (Query)
  54 import Network.Wai
  55 import Network.Wai.Handler.Warp hiding (defaultSettings)
  56 import Network.Wai.Middleware.Cors
  57 import Network.Wai.Middleware.RequestLogger
  58 import Paths_gargantext (getDataDir)
  59 import Servant
  60 import System.FilePath
  61
  62 data Mode = Dev | Mock | Prod
  63   deriving (Show, Read, Generic)
  64
  65 -- | startGargantext takes as parameters port number and Ini file.
  66 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  67 startGargantext mode port file = do
  68   env <- newEnv port file
  69   portRouteInfo port
  70   app <- makeApp env
  71   mid <- makeDevMiddleware mode
  72   run port (mid app) `finally` stopGargantext env
  73
  74 portRouteInfo :: PortNumber -> IO ()
  75 portRouteInfo port = do
  76   putStrLn "      ----Main Routes-----      "
  77   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
  78   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
  79
  80 -- TODO clean this Monad condition (more generic) ?
  81 stopGargantext :: HasNodeStorySaver env => env -> IO ()
  82 stopGargantext env = do
  83   putStrLn "----- Stopping gargantext -----"
  84   runReaderT saveNodeStory env
  85
  86 {-
  87 startGargantextMock :: PortNumber -> IO ()
  88 startGargantextMock port = do
  89   portRouteInfo port
  90   application <- makeMockApp . MockEnv $ FireWall False
  91   run port application
  92 -}
  93
  94 ----------------------------------------------------------------------
  95
  96 fireWall :: Applicative f => Request -> FireWall -> f Bool
  97 fireWall req fw = do
  98     let origin = lookup "Origin" (requestHeaders req)
  99     let host   = lookup "Host"   (requestHeaders req)
 100
 101     if  origin == Just (encodeUtf8 "http://localhost:8008")
 102        && host == Just (encodeUtf8 "localhost:3000")
 103        || (not $ unFireWall fw)
 104
 105        then pure True
 106        else pure False
 107
 108 {-
 109 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 110 makeMockApp :: MockEnv -> IO Application
 111 makeMockApp env = do
 112     let serverApp = appMock
 113
 114     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 115     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 116     let checkOriginAndHost app req resp = do
 117             blocking <- fireWall req (env ^. menv_firewall)
 118             case blocking  of
 119                 True  -> app req resp
 120                 False -> resp ( responseLBS status401 []
 121                               "Invalid Origin or Host header")
 122
 123     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 124 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 125             { corsOrigins        = Nothing --  == /*
 126             , corsMethods        = [ methodGet   , methodPost   , methodPut
 127                                    , methodDelete, methodOptions, methodHead]
 128             , corsRequestHeaders = ["authorization", "content-type"]
 129             , corsExposedHeaders = Nothing
 130             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 131             , corsVaryOrigin     = False
 132             , corsRequireOrigin  = False
 133             , corsIgnoreFailures = False
 134             }
 135
 136     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 137     --          $ Warp.defaultSettings
 138
 139     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 140     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 141 -}
 142
 143
 144 makeDevMiddleware :: Mode -> IO Middleware
 145 makeDevMiddleware mode = do
 146 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 147 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 148 --    let checkOriginAndHost app req resp = do
 149 --            blocking <- fireWall req (env ^. menv_firewall)
 150 --            case blocking  of
 151 --                True  -> app req resp
 152 --                False -> resp ( responseLBS status401 []
 153 --                              "Invalid Origin or Host header")
 154 --
 155     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 156 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 157             { corsOrigins        = Nothing --  == /*
 158             , corsMethods        = [ methodGet   , methodPost   , methodPut
 159                                    , methodDelete, methodOptions, methodHead]
 160             , corsRequestHeaders = ["authorization", "content-type"]
 161             , corsExposedHeaders = Nothing
 162             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 163             , corsVaryOrigin     = False
 164             , corsRequireOrigin  = False
 165             , corsIgnoreFailures = False
 166             }
 167
 168     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 169     --          $ Warp.defaultSettings
 170
 171     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 172     case mode of
 173       Prod -> pure $ logStdout . corsMiddleware
 174       _    -> pure $ logStdoutDev . corsMiddleware
 175
 176 ---------------------------------------------------------------------
 177 -- | API Global
 178 ---------------------------------------------------------------------
 179
 180 ---------------------------
 181
 182
 183 -- TODO-SECURITY admin only: withAdmin
 184 -- Question: How do we mark admins?
 185 {-
 186 serverGargAdminAPI :: GargServer GargAdminAPI
 187 serverGargAdminAPI =  roots
 188                  :<|> nodesAPI
 189 -}
 190
 191 ---------------------------------------------------------------------
 192 --gargMock :: Server GargAPI
 193 --gargMock = mock apiGarg Proxy
 194 ---------------------------------------------------------------------
 195
 196
 197 makeApp :: EnvC env => env -> IO Application
 198 makeApp env = do
 199   serv <- server env
 200   (ekgStore, ekgMid) <- newEkgStore api
 201   ekgDir <- (</> "ekg-assets") <$> getDataDir
 202   return $ ekgMid $ serveWithContext apiWithEkg cfg
 203     (ekgServer ekgDir ekgStore :<|> serv)
 204   where
 205     cfg :: Servant.Context AuthContext
 206     cfg = env ^. settings . jwtSettings
 207        :. env ^. settings . cookieSettings
 208     -- :. authCheck env
 209        :. EmptyContext
 210
 211 --appMock :: Application
 212 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 213 ---------------------------------------------------------------------
 214 api :: Proxy API
 215 api  = Proxy
 216
 217 apiWithEkg :: Proxy (EkgAPI :<|> API)
 218 apiWithEkg = Proxy
 219
 220 apiGarg :: Proxy GargAPI
 221 apiGarg  = Proxy
 222 ---------------------------------------------------------------------
 223
 224 {- UNUSED
 225 --import GHC.Generics (D1, Meta (..), Rep, Generic)
 226 --import GHC.TypeLits (AppendSymbol, Symbol)
 227 ---------------------------------------------------------------------
 228 -- Type Family for the Documentation
 229 type family TypeName (x :: *) :: Symbol where
 230     TypeName Int  = "Int"
 231     TypeName Text = "Text"
 232     TypeName x    = GenericTypeName x (Rep x ())
 233
 234 type family GenericTypeName t (r :: *) :: Symbol where
 235     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 236
 237 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 238 -}