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