blob: 97c849c6681dc14b5f64275c325f04837e658f74 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Aeson
import GHC.Generics
import HFlags
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger
import Servant
import System.Exit
import System.IO.Unsafe (unsafePerformIO)
import Data.List.Split
import qualified Authentication
import Data
import PhotoStore
defineFlag "port" (8081 :: Int) "Port to serve on"
defineFlag "host" ("*6" :: String) "Host to serve on (*6 for ipv6 mode)"
defineFlag "pending_path" ("" :: String) "Path to pending albums"
defineFlag "photos_path" ("" :: String) "Path to permanent albums"
defineFlag "allowed_users" ("" :: String) "Comma separated list of emails"
$(return []) -- Somehow forces the flags to be set.
instance ToJSON Album
instance FromJSON Album
data RenameRequest = RenameRequest
{ from :: Album
, to :: Album
} deriving (Eq, Show, Generic)
instance FromJSON RenameRequest
instance ToJSON RenameError
type WithAuthentication = Header "X-Token" String
type PhotoApi =
"albums"
:> WithAuthentication
:> Get '[JSON] [Album]
:<|> "rename"
:> WithAuthentication
:> ReqBody '[JSON] RenameRequest
:> Post '[JSON] (Either RenameError ())
type Token = String
isAuthenticated = Authentication.isAuthenticated users cache
where users = splitOn "," flags_allowed_users
cache = unsafePerformIO (newMVar [])
config = Config
{ pendingPath = flags_pending_path
, photosPath = flags_photos_path
}
checkAuthenticated :: Maybe Token -> EitherT ServantErr IO ()
checkAuthenticated (Just token) = liftIO (isAuthenticated token) >>= \case
True -> return ()
False -> left err503 { errBody = "Not authenticated" }
checkAuthenticated Nothing = left err503 { errBody = "Missing token" }
server :: Server PhotoApi
server = albums
:<|> rename
where albums token = checkAuthenticated token >> liftIO (getAlbums config)
rename token (RenameRequest from to) = do
_ <- checkAuthenticated token
liftIO $ runEitherT (renameAlbum config from to)
photoApi :: Proxy PhotoApi
photoApi = Proxy
app :: Application
app = logStdoutDev $ serve photoApi server
port = 8081
settings :: Settings
settings = setHost "*6" . setPort 8081 $ defaultSettings
main :: IO ()
main = do
$initHFlags "photos"
print $ splitOn "," flags_allowed_users
when (flags_pending_path == "") (die "--pending_path must be specified")
when (flags_photos_path == "") (die "--photos_path must be specified")
putStrLn $ "Starting server on port: " ++ (show port)
runSettings settings app
|
