res.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}

module ReLe.Svc.Res (runSvc) where

import ReLe.Core
import ReLe.Auth
import ReLe.Res
import ReLe.Service.Limit (limited)

import qualified Data.ByteString.Lazy as BS
import Control.Monad.Reader
import Control.Monad.Trans.Either
import Data.Int
import Data.Aeson (ToJSON, FromJSON)
import Data.Text
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import GHC.Generics
import Network.Wai
import Network.Wai.Parse
import Network.Wai.Middleware.Cors
import Network.Wai.Handler.Warp
import Servant
import Data.Time.Clock

data LimitedServices = SVC_PING
                     | SVC_GET_RES
                     | SVC_SET_RES
        deriving Show

-- https://gist.github.com/alpmestan/3629f511357bc794e745
data Files
instance HasServer api => HasServer (Files :> api) where
  type ServerT (Files :> api) m = [File BS.ByteString] -> ServerT api m
  route Proxy subserver req respond = do    (_, files) <- parseRequestBody lbsBackEnd req
                                            route (Proxy :: Proxy api) (subserver files) req respond

-- | Start the full @CoreStack@ as a web server application.
-- Bind on port indicated by @PORT@ environment variable or @80@ if not set.
-- The log service name is @ReLe.Svc.Res@
runSvc :: IO ()
runSvc = do
    coreStackConfig <- setupCoreStack "ReLe.Svc.Res"
    runEnv 80 $ simpleCors $ app coreStackConfig

type RLUMAPI =  Header "X-Auth-Token" Text :> Get '[JSON] (Result PingResponse)
    :<|>        Header "X-Auth-Token" Text :> Capture "userId" Int64 :> Capture "resId" Text :> Get '[OctetStream] BS.ByteString
    :<|>        Header "X-Auth-Token" Text :> Capture "resId" Text :> Files :> Post '[JSON] (Result ())

data PingResponse = PingResponse { serverTime :: UTCTime } deriving (Show, Generic)
instance ToJSON PingResponse
rlumPing :: Maybe Text -> AppM (Result PingResponse)
rlumPing a = rlim a SVC_PING $ PingResponse <$> liftIO getCurrentTime

rlumResPut :: Maybe Text -> Text -> [File BS.ByteString] -> AppM (Result ())
rlumResPut a resid fs = rlim a SVC_SET_RES $ case fs of
    [(bs, fi)] -> getUserId >>= flip resUpsert (Res resid (BS.toStrict $ fileContent fi) (decodeUtf8 $ fileContentType fi))
    _          -> failWith "One and only one file must be send"

rlumResGet :: Maybe Text -> Int64 -> Text -> AppM BS.ByteString
rlumResGet a uid resid = do
    img <- rlim a SVC_SET_RES $ do
              rs <- resDetail (toSqlKey uid) resid
              return $ BS.fromStrict $ resData rs
    case img of
      (Result (Just err)  _      ) -> Prelude.error err
      (Result Nothing   (Just bs)) -> return bs



server :: ServerT RLUMAPI AppM
server =    rlumPing
    :<|>    rlumResGet
    :<|>    rlumResPut

rlim :: Show s => Maybe Text -> s -> AuthStack a -> AppM (Result a)
rlim authToken limitedService = rlum authToken . limited limitedService

data Result a = Result
    { error   :: Maybe String
    , success :: Maybe a
    } deriving (Eq, Show, Generic)

instance ToJSON a => ToJSON (Result a)
instance FromJSON a => FromJSON (Result a)

rlum :: Maybe Text -> AuthStack a -> AppM (Result a)
rlum Nothing          _ = lift $ left err403
rlum (Just authToken) k = do
    c <- ask
    r <- liftIO $ runRL c $ authenticate (encodeUtf8 authToken) $ ensureUserExists >> k
    return $ case r of
                Left  e -> Result (Just e) Nothing
                Right a -> Result Nothing (Just a)

type AppM = ReaderT Config (EitherT ServantErr IO)

rlumAPI :: Proxy RLUMAPI
rlumAPI = Proxy

app :: Config -> Application
app = serve rlumAPI . readerServer

readerServer :: Config -> Server RLUMAPI
readerServer cfg = enter (readerToEither cfg) server

readerToEither :: Config -> AppM :~> EitherT ServantErr IO
readerToEither cfg = Nat $ \x -> runReaderT x cfg