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 (catch, finally, SomeException)
  35 import Control.Lens
  36 import Control.Monad.Except
  37 import Control.Monad.Reader (runReaderT)
  38 import Data.Either
  39 import Data.List (lookup)
  40 import Data.Text (pack)
  41 import Data.Text.Encoding (encodeUtf8)
  42 import Data.Text.IO (putStrLn)
  43 import Data.Validity
  44 import GHC.Base (Applicative)
  45 import GHC.Generics (Generic)
  46 import Gargantext.API.Admin.Auth.Types (AuthContext)
  47 import Gargantext.API.Admin.Settings (newEnv)
  48 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
  49 import Gargantext.API.EKG
  50 import Gargantext.API.Ngrams (saveNodeStory)
  51 import Gargantext.API.Prelude
  52 import Gargantext.API.Routes
  53 import Gargantext.API.Server (server)
  54 import Gargantext.Core.NodeStory
  55 import qualified Gargantext.Database.Prelude as DB
  56 import Gargantext.Prelude hiding (putStrLn)
  57 import Network.HTTP.Types hiding (Query)
  58 import Network.Wai
  59 import Network.Wai.Handler.Warp hiding (defaultSettings)
  60 import Network.Wai.Middleware.Cors
  61 import Network.Wai.Middleware.RequestLogger
  62 import Paths_gargantext (getDataDir)
  63 import Servant
  64 import System.FilePath
  65
  66 data Mode = Dev | Mock | Prod
  67   deriving (Show, Read, Generic)
  68
  69 -- | startGargantext takes as parameters port number and Ini file.
  70 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  71 startGargantext mode port file = do
  72   env <- newEnv port file
  73   runDbCheck env
  74   portRouteInfo port
  75   app <- makeApp env
  76   mid <- makeDevMiddleware mode
  77   run port (mid app) `finally` stopGargantext env
  78
  79   where runDbCheck env = do
  80           r <- runExceptT (runReaderT DB.dbCheck env) `catch`
  81             (\(_ :: SomeException) -> return $ Right False)
  82           case r of
  83             Right True -> return ()
  84             _ -> panic $
  85               "You must run 'gargantext-init " <> pack file <>
  86               "' before running gargantext-server (only the first time)."
  87
  88 portRouteInfo :: PortNumber -> IO ()
  89 portRouteInfo port = do
  90   putStrLn "      ----Main Routes-----      "
  91   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
  92   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
  93
  94 -- TODO clean this Monad condition (more generic) ?
  95 stopGargantext :: HasNodeStorySaver env => env -> IO ()
  96 stopGargantext env = do
  97   putStrLn "----- Stopping gargantext -----"
  98   runReaderT saveNodeStory env
  99
 100 {-
 101 startGargantextMock :: PortNumber -> IO ()
 102 startGargantextMock port = do
 103   portRouteInfo port
 104   application <- makeMockApp . MockEnv $ FireWall False
 105   run port application
 106 -}
 107
 108 ----------------------------------------------------------------------
 109
 110 fireWall :: Applicative f => Request -> FireWall -> f Bool
 111 fireWall req fw = do
 112     let origin = lookup "Origin" (requestHeaders req)
 113     let host   = lookup "Host"   (requestHeaders req)
 114
 115     if  origin == Just (encodeUtf8 "http://localhost:8008")
 116        && host == Just (encodeUtf8 "localhost:3000")
 117        || (not $ unFireWall fw)
 118
 119        then pure True
 120        else pure False
 121
 122 {-
 123 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 124 makeMockApp :: MockEnv -> IO Application
 125 makeMockApp env = do
 126     let serverApp = appMock
 127
 128     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 129     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 130     let checkOriginAndHost app req resp = do
 131             blocking <- fireWall req (env ^. menv_firewall)
 132             case blocking  of
 133                 True  -> app req resp
 134                 False -> resp ( responseLBS status401 []
 135                               "Invalid Origin or Host header")
 136
 137     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 138 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 139             { corsOrigins        = Nothing --  == /*
 140             , corsMethods        = [ methodGet   , methodPost   , methodPut
 141                                    , methodDelete, methodOptions, methodHead]
 142             , corsRequestHeaders = ["authorization", "content-type"]
 143             , corsExposedHeaders = Nothing
 144             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 145             , corsVaryOrigin     = False
 146             , corsRequireOrigin  = False
 147             , corsIgnoreFailures = False
 148             }
 149
 150     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 151     --          $ Warp.defaultSettings
 152
 153     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 154     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 155 -}
 156
 157
 158 makeDevMiddleware :: Mode -> IO Middleware
 159 makeDevMiddleware mode = do
 160 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 161 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 162 --    let checkOriginAndHost app req resp = do
 163 --            blocking <- fireWall req (env ^. menv_firewall)
 164 --            case blocking  of
 165 --                True  -> app req resp
 166 --                False -> resp ( responseLBS status401 []
 167 --                              "Invalid Origin or Host header")
 168 --
 169     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 170 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 171             { corsOrigins        = Nothing --  == /*
 172             , corsMethods        = [ methodGet   , methodPost   , methodPut
 173                                    , methodDelete, methodOptions, methodHead]
 174             , corsRequestHeaders = ["authorization", "content-type"]
 175             , corsExposedHeaders = Nothing
 176             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 177             , corsVaryOrigin     = False
 178             , corsRequireOrigin  = False
 179             , corsIgnoreFailures = False
 180             }
 181
 182     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 183     --          $ Warp.defaultSettings
 184
 185     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 186     case mode of
 187       Prod -> pure $ logStdout . corsMiddleware
 188       _    -> pure $ logStdoutDev . corsMiddleware
 189
 190 ---------------------------------------------------------------------
 191 -- | API Global
 192 ---------------------------------------------------------------------
 193
 194 ---------------------------
 195
 196
 197 -- TODO-SECURITY admin only: withAdmin
 198 -- Question: How do we mark admins?
 199 {-
 200 serverGargAdminAPI :: GargServer GargAdminAPI
 201 serverGargAdminAPI =  roots
 202                  :<|> nodesAPI
 203 -}
 204
 205 ---------------------------------------------------------------------
 206 --gargMock :: Server GargAPI
 207 --gargMock = mock apiGarg Proxy
 208 ---------------------------------------------------------------------
 209
 210 makeApp :: (Typeable env, EnvC env) => env -> IO Application
 211 makeApp env = do
 212   serv <- server env
 213   (ekgStore, ekgMid) <- newEkgStore api
 214   ekgDir <- (</> "ekg-assets") <$> getDataDir
 215   return $ ekgMid $ serveWithContext apiWithEkg cfg
 216     (ekgServer ekgDir ekgStore :<|> serv)
 217   where
 218     cfg :: Servant.Context AuthContext
 219     cfg = env ^. settings . jwtSettings
 220        :. env ^. settings . cookieSettings
 221     -- :. authCheck env
 222        :. EmptyContext
 223
 224 --appMock :: Application
 225 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 226 ---------------------------------------------------------------------
 227 api :: Proxy API
 228 api  = Proxy
 229
 230 apiWithEkg :: Proxy (EkgAPI :<|> API)
 231 apiWithEkg = Proxy
 232
 233 apiGarg :: Proxy GargAPI
 234 apiGarg  = Proxy
 235 ---------------------------------------------------------------------
 236
 237 {- UNUSED
 238 --import GHC.Generics (D1, Meta (..), Rep, Generic)
 239 --import GHC.TypeLits (AppendSymbol, Symbol)
 240 ---------------------------------------------------------------------
 241 -- Type Family for the Documentation
 242 type family TypeName (x :: *) :: Symbol where
 243     TypeName Int  = "Int"
 244     TypeName Text = "Text"
 245     TypeName x    = GenericTypeName x (Rep x ())
 246
 247 type family GenericTypeName t (r :: *) :: Symbol where
 248     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 249
 250 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 251 -}