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