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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | simple server offering linting "as a service"
module Main where
import Universum
import Config (Config, loadConfig, port,
template, verbose)
import Data.Aeson (FromJSON)
import qualified Data.Aeson as A
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Text.Encoding.Base64.URL (decodeBase64Unpadded)
import Data.Tiled (GlobalId, LocalId,
Tiledmap)
import GHC.Generics (Generic (Rep, from, to),
K1 (K1), M1 (M1), U1,
type (:*:) ((:*:)),
type (:+:) (..))
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
import Network.Wai.Middleware.Gzip (def)
import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
RequestLoggerSettings (..),
mkRequestLogger)
import Servant (Application, Capture,
CaptureAll,
FromHttpApiData (parseUrlPiece),
Get, Handler, JSON, Raw,
Server, err400,
err404, serve,
throwError,
type (:<|>) (..),
type (:>))
import Servant.Server.StaticFiles (serveDirectoryWebApp)
-- | a map's filename ending in .json
-- (a newtype to differentiate between maps and assets in a route)
newtype JsonFilename = JsonFilename Text
instance FromHttpApiData JsonFilename where
parseUrlPiece url =
if ".json" `T.isSuffixOf` url
then Right (JsonFilename url)
else Left url
newtype Tag = Tag Text
deriving (Generic, FromJSON)
data MapParams = MapParams
{ contentWarnings :: [Tag]
, backUrl :: Text
, exitUrl :: Maybe Text
, substs :: Map Text Text
} deriving (Generic, FromJSON)
instance FromHttpApiData MapParams where
parseUrlPiece urltext =
case decodeBase64Unpadded urltext of
Right text -> case A.decode (encodeUtf8 text) of
Just params -> params
Nothing -> Left "decoding params failed?"
-- for fun (and testing) also allow non-encoded json
Left _err -> case A.decode (encodeUtf8 urltext) of
Just params -> Right params
Nothing -> Left "decoding MapParams failed"
-- | actual set of routes: api for json & html + static pages from disk
type Routes =
Capture "map.json" JsonFilename :> Capture "params" MapParams :> Get '[JSON] Tiledmap
-- explicitly capture broken json to return 400 instead of looking for files
:<|> Capture "map.json" JsonFilename :> CaptureAll "rest" Text :> Get '[JSON] Void
:<|> Raw
class Substitutable s where
substitute :: s -> Map Text Text -> s
instance Substitutable Text where
substitute orig subst = "meow" -- TODO: write a simple lexer to replace @vars@ or sth
instance {-# OVERLAPS #-} Substitutable String where
substitute orig substs = toString (substitute (toText orig) substs)
instance {-# OVERLAPPING #-} (Functor a, Substitutable b) => Substitutable (a b) where
substitute orig subst = map (`substitute` subst) orig
instance {-# OVERLAPS #-} Substitutable A.Value where
substitute = const
instance Substitutable Int where
substitute = const
instance Substitutable GlobalId where
substitute = const
instance Substitutable LocalId where
substitute = const
instance Substitutable Double where
substitute = const
instance Substitutable Float where
substitute = const
class GSubstitutable i where
gsubstitute :: i p -> Map Text Text -> i p
instance Substitutable c => GSubstitutable (K1 i c) where
gsubstitute (K1 text) = K1 . substitute text
instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :*: b) where
gsubstitute (a :*: b) substs = gsubstitute a substs :*: gsubstitute b substs
instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :+: b) where
gsubstitute (L1 a) = L1 . gsubstitute a
gsubstitute (R1 a) = R1 . gsubstitute a
instance (GSubstitutable a) => GSubstitutable (M1 x y a) where
gsubstitute (M1 a) = M1 . gsubstitute a
instance GSubstitutable U1 where
gsubstitute = const
instance {-# OVERLAPPABLE #-} (GSubstitutable (Rep a), Generic a) => Substitutable a where
substitute a substs = to (gsubstitute (from a) substs)
mkMap :: Config True -> Tiledmap -> MapParams -> Tiledmap
mkMap _config basemap params =
substitute basemap (substs params)
mapHandler :: Config True -> JsonFilename -> MapParams -> Handler Tiledmap
mapHandler config (JsonFilename mapname) params =
case M.lookup mapname (snd $ view template config) of
Just basemap -> pure $ mkMap config basemap params
Nothing -> throwError err404
-- | Complete set of routes: API + HTML sites
server :: Config True -> Server Routes
server config = mapHandler config
:<|> (\_ _ -> throwError err400)
:<|> serveDirectoryWebApp (fst . view template $ config)
app :: Config True -> Application
app = serve (Proxy @Routes) . server
main :: IO ()
main = do
config <- loadConfig "./cwality-config.toml"
loggerMiddleware <- mkRequestLogger
$ def { outputFormat = Detailed (view verbose config) }
let warpsettings =
setPort (view port config)
defaultSettings
runSettings warpsettings
. loggerMiddleware
$ app config
|
