|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE DeriveAnyClass #-} |
| 3 | +{-# LANGUAGE DeriveGeneric #-} |
| 4 | +{-# LANGUAGE FlexibleContexts #-} |
| 5 | +{-# LANGUAGE OverloadedStrings #-} |
| 6 | +{-# LANGUAGE RecordWildCards #-} |
| 7 | +{-# LANGUAGE TypeOperators #-} |
| 8 | + |
| 9 | +module Postmap.Serve where |
| 10 | + |
| 11 | +import Data.Foldable (forM_) |
| 12 | +import Data.List (find) |
| 13 | +import Data.Maybe (fromMaybe) |
| 14 | +import qualified Data.Text as T |
| 15 | +import Effectful (IOE, (:>)) |
| 16 | +import Effectful.Concurrent (Concurrent, runConcurrent) |
| 17 | +import GHC.Generics (Generic) |
| 18 | +import Postmap.Introspect (ColumnName (..), TableName (..), TableSchemaName (unTableSchemaName)) |
| 19 | +import Postmap.Spec |
| 20 | +import Text.Read (readMaybe) |
| 21 | +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) |
| 22 | +import Web.Hyperbole (Eff) |
| 23 | +import qualified Web.Hyperbole as WH |
| 24 | +import Web.Hyperbole.Route (Route (..)) |
| 25 | +import qualified Zamazingo.Text as Z.Text |
| 26 | + |
| 27 | + |
| 28 | +runWeb :: Spec -> IO () |
| 29 | +runWeb spec = do |
| 30 | + putStrLn "Starting schema editor on http://localhost:3003" |
| 31 | + WH.run 3003 (app spec) |
| 32 | + |
| 33 | + |
| 34 | +app :: Spec -> WH.Application |
| 35 | +app spec = |
| 36 | + WH.liveApp |
| 37 | + (WH.basicDocument "Postmap Schema Editor") |
| 38 | + (runApp . WH.routeRequest $ router spec) |
| 39 | + |
| 40 | + |
| 41 | +runApp :: IOE :> es => Eff (Concurrent : es) a -> Eff es a |
| 42 | +runApp = |
| 43 | + runConcurrent |
| 44 | + |
| 45 | + |
| 46 | +data AppRoute |
| 47 | + = AppRouteHome |
| 48 | + | AppRouteRecord !RecordName |
| 49 | + | AppRouteAbout |
| 50 | + deriving (Eq, Generic) |
| 51 | + |
| 52 | + |
| 53 | +instance Route AppRoute where |
| 54 | + defRoute = AppRouteHome |
| 55 | + |
| 56 | + |
| 57 | + routePath AppRouteHome = [] |
| 58 | + routePath (AppRouteRecord name) = ["records", unRecordName name] |
| 59 | + routePath AppRouteAbout = ["about"] |
| 60 | + |
| 61 | + |
| 62 | + matchRoute [] = Just AppRouteHome |
| 63 | + matchRoute ["records", name] = either (const Nothing) (Just . AppRouteRecord) (mkRecordName name) |
| 64 | + matchRoute ["about"] = Just AppRouteAbout |
| 65 | + matchRoute _ = Nothing |
| 66 | + |
| 67 | + |
| 68 | +router |
| 69 | + :: WH.Hyperbole :> es |
| 70 | + => Concurrent :> es |
| 71 | + => IOE :> es |
| 72 | + => Spec |
| 73 | + -> AppRoute |
| 74 | + -> Eff es WH.Response |
| 75 | +router spec AppRouteHome = pageHome spec |
| 76 | +router spec@Spec {..} (AppRouteRecord x) = pageRecord spec x $ find (\Record {..} -> recordName == x) specRecords |
| 77 | +router _spec AppRouteAbout = pageAbout |
| 78 | + |
| 79 | + |
| 80 | +pageHome |
| 81 | + :: WH.Hyperbole :> es |
| 82 | + => Spec |
| 83 | + -> Eff es WH.Response |
| 84 | +pageHome spec = WH.view $ do |
| 85 | + canvas (mkSideBar Nothing spec) "hello" |
| 86 | + |
| 87 | + |
| 88 | +mkSideBar :: Maybe RecordName -> Spec -> WH.View c () |
| 89 | +mkSideBar mrn Spec {..} = do |
| 90 | + WH.el (WH.bold . WH.fontSize 20) "Records" |
| 91 | + forM_ specRecords $ \Record {..} -> do |
| 92 | + WH.link |
| 93 | + (WH.routeUrl (AppRouteRecord recordName)) |
| 94 | + (WH.fontSize 16 . (if Just recordName == mrn then WH.bold else id) . WH.color Primary) |
| 95 | + (WH.text $ unRecordName recordName) |
| 96 | + |
| 97 | + |
| 98 | +pageRecord :: WH.Hyperbole :> es => Spec -> RecordName -> Maybe Record -> Eff es WH.Response |
| 99 | +pageRecord spec name mRecord = WH.view $ do |
| 100 | + canvas (mkSideBar (Just name) spec) . WH.el (WH.pad 10) $ do |
| 101 | + WH.el (WH.bold . WH.fontSize 24) (WH.text $ "Record: " <> unRecordName name) |
| 102 | + case mRecord of |
| 103 | + Nothing -> WH.el (WH.fontSize 16) "Record not found." |
| 104 | + Just Record {..} -> WH.col (WH.gap 10) $ do |
| 105 | + WH.el (WH.fontSize 16) $ labelled "Title" (WH.text $ fromMaybe "<untitled>" recordTitle) |
| 106 | + WH.el (WH.fontSize 16) $ labelled "Description" (WH.text $ fromMaybe "<no description>" recordDescription) |
| 107 | + WH.el (WH.fontSize 16) $ labelled "Table Schema" (WH.text $ unTableSchemaName recordTableSchema) |
| 108 | + WH.el (WH.fontSize 16) $ labelled "Table Name" (WH.text $ unTableName recordTableName) |
| 109 | + WH.el (WH.fontSize 16) $ labelled "Is View?" (WH.text $ if recordIsView then "Yes" else "No") |
| 110 | + WH.el (WH.bold . WH.fontSize 18) "Uniques" |
| 111 | + uniquesTable recordUniques |
| 112 | + WH.el (WH.bold . WH.fontSize 18) "Fields" |
| 113 | + fieldsTable recordFields |
| 114 | + where |
| 115 | + labelled x s = WH.row id $ do |
| 116 | + WH.col id $ WH.el (WH.bold . WH.pad 6) (WH.text x) |
| 117 | + WH.col WH.grow $ WH.el (WH.pad 6) s |
| 118 | + uniquesTable uniques = |
| 119 | + WH.table id uniques $ do |
| 120 | + WH.tcol (WH.th hd "Unique / Unique Together") $ \unique -> WH.td cell . WH.text $ T.intercalate ", " (unFieldName <$> unique) |
| 121 | + where |
| 122 | + hd = cell . WH.bold |
| 123 | + cell = WH.pad 4 . WH.border 1 |
| 124 | + fieldsTable fields = |
| 125 | + WH.table id fields $ do |
| 126 | + WH.tcol (WH.th hd "Name") $ \Field {..} -> WH.td cell . WH.text $ unFieldName fieldName |
| 127 | + WH.tcol (WH.th hd "Type") $ \Field {..} -> WH.td cell . WH.text $ fromMaybe "<no-type-given>" fieldType |
| 128 | + WH.tcol (WH.th hd "Column") $ \Field {..} -> WH.td cell . WH.text $ unColumnName fieldColumnName |
| 129 | + WH.tcol (WH.th hd "Column Type") $ \Field {..} -> WH.td cell . WH.text $ fieldColumnType |
| 130 | + WH.tcol (WH.th hd "Nullable") $ \Field {..} -> WH.td cell . WH.text $ if fieldNotNullable then "NOT NULL" else "NULL" |
| 131 | + WH.tcol (WH.th hd "Primary Key") $ \Field {..} -> WH.td cell . WH.text $ if fieldIsPrimaryKey then "PRIMARY KEY" else "" |
| 132 | + WH.tcol (WH.th hd "Unique") $ \Field {..} -> WH.td cell . WH.text $ if fieldIsUnique then "UNIQUE" else "" |
| 133 | + WH.tcol (WH.th hd "Reference") $ \Field {..} -> WH.td cell . WH.text $ maybe "" (\FieldReference {..} -> unRecordName fieldReferenceRecord <> "." <> unFieldName fieldReferenceField) fieldReference |
| 134 | + WH.tcol (WH.th hd "Description") $ \Field {..} -> WH.td cell . WH.text $ fromMaybe "<no-description>" fieldDescription |
| 135 | + where |
| 136 | + hd = cell . WH.bold |
| 137 | + cell = WH.pad 4 . WH.border 1 |
| 138 | + |
| 139 | + |
| 140 | +pageAbout |
| 141 | + :: WH.Hyperbole :> es |
| 142 | + => Eff es WH.Response |
| 143 | +pageAbout = WH.view $ do |
| 144 | + canvas "Nothing" $ do |
| 145 | + WH.el (WH.bold . WH.fontSize 32) "About" |
| 146 | + |
| 147 | + |
| 148 | +canvas :: WH.View c () -> WH.View c () -> WH.View c () |
| 149 | +canvas s x = WH.row WH.root $ do |
| 150 | + WH.col sideStyle $ do |
| 151 | + WH.link (WH.routeUrl AppRouteHome) logoStyle "postmap" |
| 152 | + s |
| 153 | + WH.space |
| 154 | + WH.link (WH.routeUrl AppRouteAbout) (WH.color Primary) "About" |
| 155 | + WH.col WH.grow x |
| 156 | + where |
| 157 | + logoStyle = |
| 158 | + WH.fontSize 32 |
| 159 | + . WH.bold |
| 160 | + . WH.color Primary |
| 161 | + . WH.textAlign WH.Center |
| 162 | + . WH.border (WH.TRBL 0 0 1 0) |
| 163 | + . WH.borderColor Primary |
| 164 | + styBorderColor = WH.borderColor SecondaryLight |
| 165 | + sideStyle = |
| 166 | + WH.border (WH.TRBL 0 1 0 0) |
| 167 | + . styBorderColor |
| 168 | + . WH.pad 8 |
| 169 | + . WH.gap (WH.PxRem 6) |
| 170 | + . WH.bg GrayLight |
| 171 | + . WH.color GrayDark |
| 172 | + . WH.fontSize 16 |
| 173 | + . WH.scroll |
| 174 | + |
| 175 | + |
| 176 | +data AppColor |
| 177 | + = White |
| 178 | + | Light |
| 179 | + | GrayLight |
| 180 | + | GrayDark |
| 181 | + | Dark |
| 182 | + | Success |
| 183 | + | Danger |
| 184 | + | Warning |
| 185 | + | Primary |
| 186 | + | PrimaryLight |
| 187 | + | Secondary |
| 188 | + | SecondaryLight |
| 189 | + deriving (Show, Read, Generic, WH.Param) |
| 190 | + |
| 191 | + |
| 192 | +instance ToHttpApiData AppColor where |
| 193 | + toQueryParam = Z.Text.tshow |
| 194 | + |
| 195 | + |
| 196 | +instance FromHttpApiData AppColor where |
| 197 | + parseQueryParam t = do |
| 198 | + case readMaybe (T.unpack t) of |
| 199 | + Nothing -> Left $ "Invalid AppColor: " <> t |
| 200 | + (Just c) -> pure c |
| 201 | + |
| 202 | + |
| 203 | +instance WH.ToColor AppColor where |
| 204 | + colorValue White = "#FFF" |
| 205 | + colorValue Light = "#F2F2F3" |
| 206 | + colorValue GrayLight = "#E3E5E9" |
| 207 | + colorValue GrayDark = "#2C3C44" |
| 208 | + colorValue Dark = "#2E3842" |
| 209 | + colorValue Primary = "#4171b7" |
| 210 | + colorValue PrimaryLight = "#6D9BD3" |
| 211 | + colorValue Secondary = "#5D5A5C" |
| 212 | + colorValue SecondaryLight = "#9D999C" |
| 213 | + colorValue Success = "#149e5a" |
| 214 | + colorValue Danger = "#ef1509" |
| 215 | + colorValue Warning = "#e1c915" |
0 commit comments