blob: fcdf9eac8dfc8a121aba3dd5bf59e176cfd0246d (
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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Data.Aeson
import GHC.Generics
import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import HFlags
import System.Exit
import Control.Monad
import Data
import PhotoStore
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Network.Wai.Middleware.RequestLogger
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"
$(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 PhotoApi =
"albums" :> Get '[JSON] [Album]
:<|> "rename" :> ReqBody '[JSON] RenameRequest :> Post '[JSON] (Either RenameError ())
:<|> "test" :> Header "X-Token" String :> Get '[JSON] ()
-- Introduce request header containing auth information.
config = Config
{ pendingPath = flags_pending_path
, photosPath = flags_photos_path
}
server :: Server PhotoApi
server = albums
:<|> rename
:<|> test
where albums = liftIO (getAlbums config)
rename :: RenameRequest -> EitherT ServantErr IO (Either RenameError ())
rename (RenameRequest from to) = liftIO $
runEitherT (renameAlbum config from to)
test token = return ()
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"
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
|
