blob: 5bf71385725f1cf3831b6f9d94ccbba6a4d9b4d0 (
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
100
101
102
103
104
105
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
module Main (main) where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Aeson
import Data.List.Split (splitOn)
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
import System.IO.Unsafe (unsafePerformIO)
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"
defineFlag "client_ids" ("" :: String) "Comma separated list of client ids"
$(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 AuthenticationHeader = Header "X-Token" String
type PhotoApi =
"albums"
:> AuthenticationHeader
:> Get '[JSON] [Album]
:<|> "rename"
:> AuthenticationHeader
:> ReqBody '[JSON] RenameRequest
:> Post '[JSON] (Either RenameError ())
:<|> "quit" :> Get '[JSON] ()
type Token = String
{-# NOINLINE cache #-}
cache = unsafePerformIO (newMVar [])
isAuthenticated = Authentication.isAuthenticated clientIds users cache
where clientIds = splitOn "," flags_client_ids
users = splitOn "," flags_allowed_users
config = Config
{ pendingPath = flags_pending_path
, photosPath = flags_photos_path
}
checkAuthenticated :: Maybe Token -> EitherT ServantErr IO ()
checkAuthenticated (Just token) = do
authenticated <- liftIO (isAuthenticated token)
unless authenticated $ left err503 { errBody = "Not authenticated" }
checkAuthenticated Nothing = left err503 { errBody = "Missing token" }
server :: Server PhotoApi
server = albums
:<|> rename
:<|> quit
where albums token = checkAuthenticated token >> liftIO (getAlbums config)
rename token (RenameRequest from to) = do
_ <- checkAuthenticated token
liftIO $ runEitherT (renameAlbum config from to)
quit = liftIO exitFailure
photoApi :: Proxy PhotoApi
photoApi = Proxy
app = logStdoutDev $ serve photoApi server
port = 8081
settings = setHost "*6" . setPort 8081 $ defaultSettings
main = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
$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
|
