Merge remote-tracking branch 'origin/dev-hackathon-fixes' into dev
[gargantext.git] / src / Gargantext / API.hs
index b2d3e45ed2f2330579363f978e085a9416b5f442..ef55742e3398644d1830249ecf1c0ffbc70c1607 100644 (file)
 {-|
 Module      : Gargantext.API
-Description : Server API
+Description : REST API declaration
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
 Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
-Main REST API of Gargantext (both Server and Client sides)
+Main (RESTful) API of the instance Gargantext.
 
-TODO App type, the main monad in which the bot code is written with.
-Provide config, state, logs and IO
- type App m a =  ( MonadState AppState m
-                 , MonadReader Conf m
-                 , MonadLog (WithSeverity Doc) m
-                 , MonadIO m) => m a
-Thanks @yannEsposito for this.
--}
+The Garg-API is typed to derive the documentation, the mock and tests.
+
+This API is indeed typed in order to be able to derive both the server
+and the client sides.
 
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+The Garg-API-Monad enables:
+  - Security (WIP)
+  - Features (WIP)
+  - Database connection (long term)
+  - In Memory stack management (short term)
+  - Logs (WIP)
 
-{-# LANGUAGE DataKinds       #-}
-{-# LANGUAGE DeriveGeneric   #-}
-{-# LANGUAGE FlexibleInstances           #-}
-{-# LANGUAGE TypeOperators   #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedStrings           #-}
+Thanks to Yann Esposito for our discussions at the start and to Nicolas
+Pouillard (who mainly made it).
+
+-}
 
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeOperators        #-}
 module Gargantext.API
       where
 
-import Gargantext.Prelude
-
+import Control.Exception (catch, finally, SomeException)
+import Control.Lens
+import Control.Monad.Except
+import Control.Monad.Reader (runReaderT)
+import Data.Either
+import Data.List (lookup)
+import Data.Text (pack)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Text.IO (putStrLn)
+import Data.Validity
+import GHC.Base (Applicative)
+import GHC.Generics (Generic)
+import Gargantext.API.Admin.Auth.Types (AuthContext)
+import Gargantext.API.Admin.EnvTypes (Env)
+import Gargantext.API.Admin.Settings (newEnv)
+import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
+import Gargantext.API.EKG
+import Gargantext.API.Ngrams (saveNodeStoryImmediate)
+import Gargantext.API.Routes
+import Gargantext.API.Server (server)
+import Gargantext.Core.NodeStory
+import qualified Gargantext.Database.Prelude as DB
+import Gargantext.Prelude hiding (putStrLn)
+import Network.HTTP.Types hiding (Query)
 import Network.Wai
-import Network.Wai.Handler.Warp
-
+import Network.Wai.Handler.Warp hiding (defaultSettings)
+import Network.Wai.Middleware.Cors
+import Network.Wai.Middleware.RequestLogger
+import Paths_gargantext (getDataDir)
 import Servant
-import Servant.Mock (mock)
--- import Servant.API.Stream
+import System.FilePath
 
-import Data.Text (pack)
-import Database.PostgreSQL.Simple (Connection, connect)
-import System.IO (FilePath, print)
-
--- import Gargantext.API.Auth
-import Gargantext.API.Node ( Roots    , roots
-                           , NodeAPI  , nodeAPI
-                           , NodesAPI , nodesAPI
-                           )
-import Gargantext.API.Count ( CountAPI, count, Query)
-
-import Gargantext.Database.Utils (databaseParameters)
-
----------------------------------------------------------------------
----------------------------------------------------------------------
-type PortNumber = Int
----------------------------------------------------------------------
+data Mode = Dev | Mock | Prod
+  deriving (Show, Read, Generic)
 
 -- | startGargantext takes as parameters port number and Ini file.
-startGargantext :: PortNumber -> FilePath -> IO ()
-startGargantext port file = do
-  print ("Starting Gargantext server" <> show port)
-  print ("http://localhost:" <> show port)
-  param <- databaseParameters file
-  conn  <- connect param
-  run port ( app conn )
-
+startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
+startGargantext mode port file = do
+  env <- newEnv port file
+  runDbCheck env
+  portRouteInfo port
+  app <- makeApp env
+  mid <- makeDevMiddleware mode
+  run port (mid app) `finally` stopGargantext env
+
+  where runDbCheck env = do
+          r <- runExceptT (runReaderT DB.dbCheck env) `catch`
+            (\(_ :: SomeException) -> return $ Right False)
+          case r of
+            Right True -> return ()
+            _ -> panic $
+              "You must run 'gargantext-init " <> pack file <>
+              "' before running gargantext-server (only the first time)."
+
+portRouteInfo :: PortNumber -> IO ()
+portRouteInfo port = do
+  putStrLn "      ----Main Routes-----      "
+  putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
+  putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
+
+-- TODO clean this Monad condition (more generic) ?
+stopGargantext :: HasNodeStoryImmediateSaver env => env -> IO ()
+stopGargantext env = do
+  putStrLn "----- Stopping gargantext -----"
+  runReaderT saveNodeStoryImmediate env
+
+{-
 startGargantextMock :: PortNumber -> IO ()
 startGargantextMock port = do
-  print (pack "Starting Mock server")
-  print (pack $ "curl "
-        <> "-H \"content-type: application/json"
-        <> "-d \'{\"query_query\":\"query\"}\'  "
-        <> "-v  http://localhost:" 
-        <> show port 
-        <>"/count"
-         )
-  run port ( serve api $ mock api Proxy )
+  portRouteInfo port
+  application <- makeMockApp . MockEnv $ FireWall False
+  run port application
+-}
+
+----------------------------------------------------------------------
+
+fireWall :: Applicative f => Request -> FireWall -> f Bool
+fireWall req fw = do
+    let origin = lookup "Origin" (requestHeaders req)
+    let host   = lookup "Host"   (requestHeaders req)
+
+    if  origin == Just (encodeUtf8 "http://localhost:8008")
+       && host == Just (encodeUtf8 "localhost:3000")
+       || (not $ unFireWall fw)
+
+       then pure True
+       else pure False
+
+{-
+-- makeMockApp :: Env -> IO (Warp.Settings, Application)
+makeMockApp :: MockEnv -> IO Application
+makeMockApp env = do
+    let serverApp = appMock
+
+    -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
+    --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
+    let checkOriginAndHost app req resp = do
+            blocking <- fireWall req (env ^. menv_firewall)
+            case blocking  of
+                True  -> app req resp
+                False -> resp ( responseLBS status401 []
+                              "Invalid Origin or Host header")
+
+    let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
+--          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
+            { corsOrigins        = Nothing --  == /*
+            , corsMethods        = [ methodGet   , methodPost   , methodPut
+                                   , methodDelete, methodOptions, methodHead]
+            , corsRequestHeaders = ["authorization", "content-type"]
+            , corsExposedHeaders = Nothing
+            , corsMaxAge         = Just ( 60*60*24 ) -- one day
+            , corsVaryOrigin     = False
+            , corsRequireOrigin  = False
+            , corsIgnoreFailures = False
+            }
+
+    --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
+    --          $ Warp.defaultSettings
+
+    --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
+    pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
+-}
+
+
+makeDevMiddleware :: Mode -> IO Middleware
+makeDevMiddleware mode = do
+-- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
+-- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
+--    let checkOriginAndHost app req resp = do
+--            blocking <- fireWall req (env ^. menv_firewall)
+--            case blocking  of
+--                True  -> app req resp
+--                False -> resp ( responseLBS status401 []
+--                              "Invalid Origin or Host header")
+--
+    let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
+--          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
+            { corsOrigins        = Nothing --  == /*
+            , corsMethods        = [ methodGet   , methodPost   , methodPut
+                                   , methodDelete, methodOptions, methodHead]
+            , corsRequestHeaders = ["authorization", "content-type"]
+            , corsExposedHeaders = Nothing
+            , corsMaxAge         = Just ( 60*60*24 ) -- one day
+            , corsVaryOrigin     = False
+            , corsRequireOrigin  = False
+            , corsIgnoreFailures = False
+            }
+
+    --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
+    --          $ Warp.defaultSettings
+
+    --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
+    case mode of
+      Prod -> pure $ logStdout . corsMiddleware
+      _    -> pure $ logStdoutDev . corsMiddleware
 
 ---------------------------------------------------------------------
+-- | API Global
 ---------------------------------------------------------------------
 
--- | Main routes of the API are typed
-type API =  "roots"  :> Roots
-       
-       :<|> "node"   :> Capture "id" Int      :> NodeAPI
-       :<|> "nodes"  :> ReqBody '[JSON] [Int] :> NodesAPI
-       
-       -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
-       :<|> "count"  :> ReqBody '[JSON] Query :> CountAPI 
-
--- /mv/<id>/<id>
--- /merge/<id>/<id>
--- /rename/<id>
-       -- :<|> "static"   
-       -- :<|> "list"     :> Capture "id" Int  :> NodeAPI
-       -- :<|> "ngrams"   :> Capture "id" Int  :> NodeAPI
-       -- :<|> "auth"     :> Capture "id" Int  :> NodeAPI
-
-
--- | Server declaration
-server :: Connection -> Server API
-server conn =  roots    conn
-          :<|> nodeAPI  conn
-          :<|> nodesAPI conn
-          :<|> count
+---------------------------
+
+
+-- TODO-SECURITY admin only: withAdmin
+-- Question: How do we mark admins?
+{-
+serverGargAdminAPI :: GargServer GargAdminAPI
+serverGargAdminAPI =  roots
+                 :<|> nodesAPI
+-}
 
 ---------------------------------------------------------------------
+--gargMock :: Server GargAPI
+--gargMock = mock apiGarg Proxy
 ---------------------------------------------------------------------
-app :: Connection -> Application
-app = serve api . server
 
+makeApp :: Env -> IO Application
+makeApp env = do
+  serv <- server env
+  (ekgStore, ekgMid) <- newEkgStore api
+  ekgDir <- (</> "ekg-assets") <$> getDataDir
+  return $ ekgMid $ serveWithContext apiWithEkg cfg
+    (ekgServer ekgDir ekgStore :<|> serv)
+  where
+    cfg :: Servant.Context AuthContext
+    cfg = env ^. settings . jwtSettings
+       :. env ^. settings . cookieSettings
+    -- :. authCheck env
+       :. EmptyContext
+
+--appMock :: Application
+--appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
+---------------------------------------------------------------------
 api :: Proxy API
-api = Proxy
+api  = Proxy
+
+apiWithEkg :: Proxy (EkgAPI :<|> API)
+apiWithEkg = Proxy
+
+apiGarg :: Proxy GargAPI
+apiGarg  = Proxy
 ---------------------------------------------------------------------
+
+{- UNUSED
+--import GHC.Generics (D1, Meta (..), Rep, Generic)
+--import GHC.TypeLits (AppendSymbol, Symbol)
 ---------------------------------------------------------------------
+-- Type Family for the Documentation
+type family TypeName (x :: *) :: Symbol where
+    TypeName Int  = "Int"
+    TypeName Text = "Text"
+    TypeName x    = GenericTypeName x (Rep x ())
+
+type family GenericTypeName t (r :: *) :: Symbol where
+    GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 
+type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
+-}