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 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  30
  31 {-# LANGUAGE ConstraintKinds      #-}
  32 {-# LANGUAGE TemplateHaskell      #-}
  33 {-# LANGUAGE TypeOperators        #-}
  34 {-# LANGUAGE KindSignatures       #-}
  35 {-# LANGUAGE ScopedTypeVariables  #-}
  36 {-# LANGUAGE TypeFamilies         #-}
  37 {-# LANGUAGE UndecidableInstances #-}
  38
  39 ---------------------------------------------------------------------
  40 module Gargantext.API
  41       where
  42 ---------------------------------------------------------------------
  43 import Control.Exception (finally)
  44 import Control.Lens
  45 import Control.Monad.Except (withExceptT)
  46 import Control.Monad.Reader (runReaderT)
  47 import Data.Aeson.Encode.Pretty (encodePretty)
  48 import Data.List (lookup)
  49 import Data.Swagger
  50 import Data.Text (Text)
  51 import Data.Text.Encoding (encodeUtf8)
  52 import Data.Validity
  53 import Data.Version (showVersion)
  54 import GHC.Base (Applicative)
  55 import GHC.Generics (D1, Meta (..), Rep, Generic)
  56 import GHC.TypeLits (AppendSymbol, Symbol)
  57 import Gargantext.API.Admin.Auth (AuthContext, auth)
  58 import Gargantext.API.Admin.FrontEnd (frontEndServer)
  59 import Gargantext.API.Admin.Settings
  60 import Gargantext.API.Ngrams (HasRepoSaver(..), saveRepo)
  61 import Gargantext.API.Prelude
  62 import Gargantext.API.Routes
  63 import Gargantext.Prelude
  64 import Network.HTTP.Types hiding (Query)
  65 import Network.Wai
  66 import Network.Wai (Request, requestHeaders)
  67 import Network.Wai.Handler.Warp hiding (defaultSettings)
  68 import Network.Wai.Middleware.Cors
  69 import Network.Wai.Middleware.RequestLogger
  70 import Servant
  71 import Servant.Auth.Server (AuthResult(..))
  72 import Servant.Auth.Swagger ()
  73 import Servant.Swagger
  74 import Servant.Swagger.UI
  75 import System.IO (FilePath)
  76 import qualified Data.ByteString.Lazy.Char8 as BL8
  77 import qualified Data.Text.IO               as T
  78 import qualified Paths_gargantext           as PG -- cabal magic build module
  79 import qualified Gargantext.API.Public      as Public
  80
  81
  82 data Mode = Dev | Mock | Prod
  83        deriving (Show, Read, Generic)
  84
  85 -- | startGargantext takes as parameters port number and Ini file.
  86 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  87 startGargantext mode port file = do
  88   env <- newEnv port file
  89   portRouteInfo port
  90   app <- makeApp env
  91   mid <- makeDevMiddleware mode
  92   run port (mid app) `finally` stopGargantext env
  93
  94 portRouteInfo :: PortNumber -> IO ()
  95 portRouteInfo port = do
  96   T.putStrLn "      ----Main Routes-----      "
  97   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
  98   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
  99
 100 -- TODO clean this Monad condition (more generic) ?
 101 stopGargantext :: HasRepoSaver env => env -> IO ()
 102 stopGargantext env = do
 103   T.putStrLn "----- Stopping gargantext -----"
 104   runReaderT saveRepo env
 105
 106 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 107 swaggerWriteJSON :: IO ()
 108 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 109
 110 -- | Swagger Specifications
 111 swaggerDoc :: Swagger
 112 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 113   & info.title       .~ "Gargantext"
 114   & info.version     .~ (cs $ showVersion PG.version)
 115   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 116   & info.description ?~ "REST API specifications"
 117   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 118   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 119                  ["Gargantext" & description ?~ "Main operations"]
 120   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 121     where
 122         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 123
 124 {-
 125 startGargantextMock :: PortNumber -> IO ()
 126 startGargantextMock port = do
 127   portRouteInfo port
 128   application <- makeMockApp . MockEnv $ FireWall False
 129   run port application
 130 -}
 131
 132 ----------------------------------------------------------------------
 133
 134 fireWall :: Applicative f => Request -> FireWall -> f Bool
 135 fireWall req fw = do
 136     let origin = lookup "Origin" (requestHeaders req)
 137     let host   = lookup "Host"   (requestHeaders req)
 138
 139     if  origin == Just (encodeUtf8 "http://localhost:8008")
 140        && host == Just (encodeUtf8 "localhost:3000")
 141        || (not $ unFireWall fw)
 142
 143        then pure True
 144        else pure False
 145
 146 {-
 147 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 148 makeMockApp :: MockEnv -> IO Application
 149 makeMockApp env = do
 150     let serverApp = appMock
 151
 152     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 153     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 154     let checkOriginAndHost app req resp = do
 155             blocking <- fireWall req (env ^. menv_firewall)
 156             case blocking  of
 157                 True  -> app req resp
 158                 False -> resp ( responseLBS status401 []
 159                               "Invalid Origin or Host header")
 160
 161     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 162 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 163             { corsOrigins        = Nothing --  == /*
 164             , corsMethods        = [ methodGet   , methodPost   , methodPut
 165                                    , methodDelete, methodOptions, methodHead]
 166             , corsRequestHeaders = ["authorization", "content-type"]
 167             , corsExposedHeaders = Nothing
 168             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 169             , corsVaryOrigin     = False
 170             , corsRequireOrigin  = False
 171             , corsIgnoreFailures = False
 172             }
 173
 174     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 175     --          $ Warp.defaultSettings
 176
 177     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 178     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 179 -}
 180
 181
 182 makeDevMiddleware :: Mode -> IO Middleware
 183 makeDevMiddleware mode = do
 184
 185     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 186     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 187 --    let checkOriginAndHost app req resp = do
 188 --            blocking <- fireWall req (env ^. menv_firewall)
 189 --            case blocking  of
 190 --                True  -> app req resp
 191 --                False -> resp ( responseLBS status401 []
 192 --                              "Invalid Origin or Host header")
 193 --
 194     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 195 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 196             { corsOrigins        = Nothing --  == /*
 197             , corsMethods        = [ methodGet   , methodPost   , methodPut
 198                                    , methodDelete, methodOptions, methodHead]
 199             , corsRequestHeaders = ["authorization", "content-type"]
 200             , corsExposedHeaders = Nothing
 201             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 202             , corsVaryOrigin     = False
 203             , corsRequireOrigin  = False
 204             , corsIgnoreFailures = False
 205             }
 206
 207     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 208     --          $ Warp.defaultSettings
 209
 210     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 211     case mode of
 212       Prod -> pure $ logStdout . corsMiddleware
 213       _    -> pure $ logStdoutDev . corsMiddleware
 214
 215 ---------------------------------------------------------------------
 216 -- | API Global
 217 ---------------------------------------------------------------------
 218 -- | Server declarations
 219 server :: forall env. EnvC env => env -> IO (Server API)
 220 server env = do
 221   -- orchestrator <- scrapyOrchestrator env
 222   pure $  schemaUiServer swaggerDoc
 223      :<|> hoistServerWithContext
 224             (Proxy :: Proxy GargAPI)
 225             (Proxy :: Proxy AuthContext)
 226             transform
 227             serverGargAPI
 228      :<|> frontEndServer
 229   where
 230     transform :: forall a. GargServerM env GargError a -> Handler a
 231     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 232
 233 showAsServantErr :: GargError -> ServerError
 234 showAsServantErr (GargServerError err) = err
 235 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
 236
 237 ---------------------------
 238
 239 serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
 240 serverGargAPI -- orchestrator
 241        =  auth
 242      :<|> gargVersion
 243      :<|> serverPrivateGargAPI
 244      :<|> Public.api
 245
 246   --   :<|> orchestrator
 247   where
 248
 249     gargVersion :: GargServer GargVersion
 250     gargVersion = pure (cs $ showVersion PG.version)
 251
 252     serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 253     serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 254     serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 255 -- Here throwAll' requires a concrete type for the monad.
 256
 257
 258 -- TODO-SECURITY admin only: withAdmin
 259 -- Question: How do we mark admins?
 260 {-
 261 serverGargAdminAPI :: GargServer GargAdminAPI
 262 serverGargAdminAPI =  roots
 263                  :<|> nodesAPI
 264 -}
 265
 266 ---------------------------------------------------------------------
 267 --gargMock :: Server GargAPI
 268 --gargMock = mock apiGarg Proxy
 269 ---------------------------------------------------------------------
 270 makeApp :: EnvC env => env -> IO Application
 271 makeApp env = serveWithContext api cfg <$> server env
 272   where
 273     cfg :: Servant.Context AuthContext
 274     cfg = env ^. settings . jwtSettings
 275        :. env ^. settings . cookieSettings
 276     -- :. authCheck env
 277        :. EmptyContext
 278
 279 --appMock :: Application
 280 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 281 ---------------------------------------------------------------------
 282 api :: Proxy API
 283 api  = Proxy
 284
 285 apiGarg :: Proxy GargAPI
 286 apiGarg  = Proxy
 287 ---------------------------------------------------------------------
 288 schemaUiServer :: (Server api ~ Handler Swagger)
 289         => Swagger -> Server (SwaggerSchemaUI' dir api)
 290 schemaUiServer = swaggerSchemaUIServer
 291
 292 ---------------------------------------------------------------------
 293 -- Type Family for the Documentation
 294 type family TypeName (x :: *) :: Symbol where
 295     TypeName Int  = "Int"
 296     TypeName Text = "Text"
 297     TypeName x    = GenericTypeName x (Rep x ())
 298
 299 type family GenericTypeName t (r :: *) :: Symbol where
 300     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 301
 302 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 303
 304