From d480cce48d04d5e4353281f014f66fd61301c393 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sat, 15 Feb 2020 23:03:40 -0800 Subject: Split buildHaskellApp into buildGhc and buildGhcjs Two functions makes it simpler to reason about what is being built and when, even if it is a bit more explicit. I also removed the dumb Apex/Aero naming thing because Server/Client is just easier to remember. --- Com/InfluencedByBooks/Aero.hs | 21 ---- Com/InfluencedByBooks/Apex.hs | 132 ---------------------- Com/InfluencedByBooks/Client.hs | 21 ++++ Com/InfluencedByBooks/Server.hs | 132 ++++++++++++++++++++++ Com/MusicMeetsComics/Aero.hs | 174 ----------------------------- Com/MusicMeetsComics/Apex.hs | 235 --------------------------------------- Com/MusicMeetsComics/Client.hs | 174 +++++++++++++++++++++++++++++ Com/MusicMeetsComics/Server.hs | 235 +++++++++++++++++++++++++++++++++++++++ Com/Simatime/buildGhc.nix | 54 +++++++++ Com/Simatime/buildGhcjs.nix | 64 +++++++++++ Com/Simatime/buildHaskellApp.nix | 90 --------------- README.md | 2 +- default.nix | 55 ++++++--- ghci | 2 +- 14 files changed, 719 insertions(+), 672 deletions(-) delete mode 100644 Com/InfluencedByBooks/Aero.hs delete mode 100644 Com/InfluencedByBooks/Apex.hs create mode 100644 Com/InfluencedByBooks/Client.hs create mode 100644 Com/InfluencedByBooks/Server.hs delete mode 100644 Com/MusicMeetsComics/Aero.hs delete mode 100644 Com/MusicMeetsComics/Apex.hs create mode 100644 Com/MusicMeetsComics/Client.hs create mode 100644 Com/MusicMeetsComics/Server.hs create mode 100644 Com/Simatime/buildGhc.nix create mode 100644 Com/Simatime/buildGhcjs.nix delete mode 100644 Com/Simatime/buildHaskellApp.nix diff --git a/Com/InfluencedByBooks/Aero.hs b/Com/InfluencedByBooks/Aero.hs deleted file mode 100644 index bd996c6..0000000 --- a/Com/InfluencedByBooks/Aero.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Front-end -module Com.InfluencedByBooks.Aero where - -import Com.InfluencedByBooks.Core (Action(..), see, init) -import Com.InfluencedByBooks.Move (move) -import Com.Simatime.Alpha -import Miso (App(..), defaultEvents, miso) - -main :: IO () -main = miso $ \u -> App { model = init u, .. } - where - initialAction = FetchPeople - update = move - view = see - events = defaultEvents - subs = [] - mountPoint = Nothing diff --git a/Com/InfluencedByBooks/Apex.hs b/Com/InfluencedByBooks/Apex.hs deleted file mode 100644 index 0328a6d..0000000 --- a/Com/InfluencedByBooks/Apex.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | Server -module Com.InfluencedByBooks.Apex where - -import qualified Clay -import Com.InfluencedByBooks.Core -import qualified Com.InfluencedByBooks.Keep as Keep -import qualified Com.InfluencedByBooks.Look as Look -import Com.Simatime.Alpha -import Com.Simatime.Network -import Data.Acid (AcidState) -import qualified Data.Acid.Abstract as Acid -import Data.Maybe (fromMaybe) -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Lazy.Encoding as Lazy -import qualified Lucid as L -import Lucid.Base -import Miso -import Network.HTTP.Media ((//), (/:)) -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Application.Static -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.Gzip -import Network.Wai.Middleware.RequestLogger -import Servant -import System.Environment (lookupEnv) - -main :: IO () -main = do - say "rise: ibb" - staticDir <- fromMaybe "static" - <$> lookupEnv "STATIC_DIR" :: IO [Char] - port <- read - <$> fromMaybe "3000" - <$> lookupEnv "PORT" :: IO Int - keep <- Keep.openLocal "_keep/" - say "port: 3000" - run port $ logStdout $ compress $ app staticDir $ keep - where - compress = gzip def { gzipFiles = GzipCompress } - -newtype HtmlPage a = HtmlPage a - deriving (Show, Eq) - -instance L.ToHtml a => L.ToHtml (HtmlPage a) where - toHtmlRaw = L.toHtml - toHtml (HtmlPage x) = - L.doctypehtml_ $ do - L.head_ $ do - L.meta_ [L.charset_ "utf-8"] - jsRef "/static/ibb.js" - cssRef "/css/main.css" - L.body_ $ do - page - where - page = L.toHtml x - jsRef href = L.with (L.script_ mempty) - [ makeAttribute "src" href - , makeAttribute "type" "text/javascript" - , makeAttribute "async" mempty - , makeAttribute "defer" mempty - ] - cssRef href = L.with - (L.link_ mempty) - [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] - -type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action - -handle404 :: Application -handle404 _ respond = respond - $ responseLBS status404 [("Content-Type", "text/html")] - $ renderBS - $ toHtml - $ HtmlPage - $ notfound - -newtype CSS = CSS { unCSS :: Text } - -instance MimeRender CSS Text where - mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict - -instance Accept CSS where - contentType _ = "text" // "css" /: ("charset", "utf-8") - -type CssRoute = "css" :> "main.css" :> Get '[CSS] Text - -type Routes - = "static" :> Raw - :<|> CssRoute - :<|> ServerRoutes - :<|> "api" :> ApiRoutes - :<|> Raw - -cssHandlers :: Server CssRoute -cssHandlers = return . Lazy.toStrict . Clay.render - $ Look.main - -app :: [Char] -> AcidState Keep.IbbKeep -> Application -app staticDir keep = serve - (Proxy @Routes) - $ static - :<|> cssHandlers - :<|> serverHandlers - :<|> apiHandlers keep - :<|> Tagged handle404 - where - static = serveDirectoryWith - (defaultWebAppSettings $ staticDir) - -type ApiRoutes = - "people" :> Get '[JSON] [Person] - -serverHandlers :: Server ServerRoutes -serverHandlers = homeHandler - where - send f u = - pure $ HtmlPage $ f Model { uri = u, people = NotAsked } - homeHandler = send home goHome - --- | for now we just have one api endpoint, which returns all the people -apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes -apiHandlers keep = - Acid.query' keep $ Keep.GetPeople 20 diff --git a/Com/InfluencedByBooks/Client.hs b/Com/InfluencedByBooks/Client.hs new file mode 100644 index 0000000..cf45511 --- /dev/null +++ b/Com/InfluencedByBooks/Client.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Front-end +module Com.InfluencedByBooks.Client where + +import Com.InfluencedByBooks.Core (Action(..), see, init) +import Com.InfluencedByBooks.Move (move) +import Com.Simatime.Alpha +import Miso (App(..), defaultEvents, miso) + +main :: IO () +main = miso $ \u -> App { model = init u, .. } + where + initialAction = FetchPeople + update = move + view = see + events = defaultEvents + subs = [] + mountPoint = Nothing diff --git a/Com/InfluencedByBooks/Server.hs b/Com/InfluencedByBooks/Server.hs new file mode 100644 index 0000000..dae17ef --- /dev/null +++ b/Com/InfluencedByBooks/Server.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | Server +module Com.InfluencedByBooks.Server where + +import qualified Clay +import Com.InfluencedByBooks.Core +import qualified Com.InfluencedByBooks.Keep as Keep +import qualified Com.InfluencedByBooks.Look as Look +import Com.Simatime.Alpha +import Com.Simatime.Network +import Data.Acid (AcidState) +import qualified Data.Acid.Abstract as Acid +import Data.Maybe (fromMaybe) +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy +import qualified Lucid as L +import Lucid.Base +import Miso +import Network.HTTP.Media ((//), (/:)) +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Application.Static +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.Gzip +import Network.Wai.Middleware.RequestLogger +import Servant +import System.Environment (lookupEnv) + +main :: IO () +main = do + say "rise: ibb" + staticDir <- fromMaybe "static" + <$> lookupEnv "STATIC_DIR" :: IO [Char] + port <- read + <$> fromMaybe "3000" + <$> lookupEnv "PORT" :: IO Int + keep <- Keep.openLocal "_keep/" + say "port: 3000" + run port $ logStdout $ compress $ app staticDir $ keep + where + compress = gzip def { gzipFiles = GzipCompress } + +newtype HtmlPage a = HtmlPage a + deriving (Show, Eq) + +instance L.ToHtml a => L.ToHtml (HtmlPage a) where + toHtmlRaw = L.toHtml + toHtml (HtmlPage x) = + L.doctypehtml_ $ do + L.head_ $ do + L.meta_ [L.charset_ "utf-8"] + jsRef "/static/ibb.js" + cssRef "/css/main.css" + L.body_ $ do + page + where + page = L.toHtml x + jsRef href = L.with (L.script_ mempty) + [ makeAttribute "src" href + , makeAttribute "type" "text/javascript" + , makeAttribute "async" mempty + , makeAttribute "defer" mempty + ] + cssRef href = L.with + (L.link_ mempty) + [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] + +type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action + +handle404 :: Application +handle404 _ respond = respond + $ responseLBS status404 [("Content-Type", "text/html")] + $ renderBS + $ toHtml + $ HtmlPage + $ notfound + +newtype CSS = CSS { unCSS :: Text } + +instance MimeRender CSS Text where + mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict + +instance Accept CSS where + contentType _ = "text" // "css" /: ("charset", "utf-8") + +type CssRoute = "css" :> "main.css" :> Get '[CSS] Text + +type Routes + = "static" :> Raw + :<|> CssRoute + :<|> ServerRoutes + :<|> "api" :> ApiRoutes + :<|> Raw + +cssHandlers :: Server CssRoute +cssHandlers = return . Lazy.toStrict . Clay.render + $ Look.main + +app :: [Char] -> AcidState Keep.IbbKeep -> Application +app staticDir keep = serve + (Proxy @Routes) + $ static + :<|> cssHandlers + :<|> serverHandlers + :<|> apiHandlers keep + :<|> Tagged handle404 + where + static = serveDirectoryWith + (defaultWebAppSettings $ staticDir) + +type ApiRoutes = + "people" :> Get '[JSON] [Person] + +serverHandlers :: Server ServerRoutes +serverHandlers = homeHandler + where + send f u = + pure $ HtmlPage $ f Model { uri = u, people = NotAsked } + homeHandler = send home goHome + +-- | for now we just have one api endpoint, which returns all the people +apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes +apiHandlers keep = + Acid.query' keep $ Keep.GetPeople 20 diff --git a/Com/MusicMeetsComics/Aero.hs b/Com/MusicMeetsComics/Aero.hs deleted file mode 100644 index 26d8aaf..0000000 --- a/Com/MusicMeetsComics/Aero.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Com.MusicMeetsComics.Aero where - -import Com.MusicMeetsComics.App ( Action(..) - , Comic(..) - , ComicReaderState(..) - , ComicReaderView(..) - , Model(..) - , AudioState(..) - , audioId - , chooseExperienceLink - , comicPlayerSpreadLink - , comicPlayerFullLink - , comicVideoLink - , handlers - , initModel - , the404 - , routes - ) -import qualified Com.Simatime.Network as Network -import Data.Aeson ( eitherDecodeStrict ) -import qualified Data.Set as Set -import qualified GHC.Show as Legacy -import JavaScript.Web.XMLHttpRequest ( Request(..) - , Method(GET) - , RequestData(NoData) - , contents - , xhrByteString - ) -import Miso -import Miso.Effect.DOM (scrollIntoView) -import qualified Miso.FFI.Audio as Audio -import qualified Miso.FFI.Document as Document -import qualified Miso.FFI.Fullscreen as Fullscreen -import Miso.String -import Protolude - --- | Entry point for a miso application -main :: IO () -main = miso $ \currentURI -> App { model = initModel currentURI, .. } - where - update = move - view = see - subs = [ uriSub HandleURI - , keyboardSub keynav - ] - events = defaultEvents - initialAction = FetchComics - mountPoint = Nothing - -(∈) :: Ord a => a -> Set a -> Bool -(∈) = Set.member - --- | Keyboard navigation - maps keys to actions. -keynav :: Set Int -> Action -keynav ks - | 37 ∈ ks = PrevPage -- ^ left arrow - | 39 ∈ ks = NextPage -- ^ right arrow - | 191 ∈ ks = DumpModel -- ^ ? - | 32 ∈ ks = ToggleAudio audioId -- ^ SPC - | otherwise = NoOp - -see :: Model -> View Action -see model = - case runRoute routes handlers uri model of - Left _ -> the404 model - Right v -> v - --- | Console-logging -foreign import javascript unsafe "console.log($1);" - say :: MisoString -> IO () - --- | Updates model, optionally introduces side effects -move :: Action -> Model -> Effect Action Model -move NoOp model = noEff model -move DumpModel model = model <# do - say $ ms $ Legacy.show model - pure NoOp -move (SelectExperience comic) model = model { cpState = ChooseExperience (comicId comic) 1 } - <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 -move (StartReading comic) model = model { cpState = Reading Spread (comicId comic) 1 } - <# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1 -move (StartWatching comic) model = model { cpState = Watching (comicId comic) } - <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 -move NextPage model = case cpState model of - Reading Spread id pg -> - model { cpState = Reading Spread id (pg+2) } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id (pg+2) - Reading Full id pg -> - model { cpState = Reading Full id (pg+1) } <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg+1) - Cover id -> - model { cpState = Reading Spread id 1 } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id 1 - _ -> noEff model -move PrevPage model = case cpState model of - Reading Spread id pg -> - model { cpState = Reading Spread id (pg-2) } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id (pg-2) - Reading Full id pg -> - model { cpState = Reading Full id (pg-1) } <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg-1) - Cover _ -> noEff model - _ -> noEff model -move (ToggleZoom c pg) m = m { cpState = newState } <# do pure act - where - goto lnk = ChangeURI $ lnk (comicId c) pg - reading v = Reading v (comicId c) pg - (newState, act) = case cpState m of - Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink) - Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink) - x -> (x, NoOp) -move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp - where - newLib | c `elem` (userLibrary model) = - Protolude.filter (/= c) $ userLibrary model - | otherwise = c : (userLibrary model) -move (HandleURI u) model = model { uri = u } <# pure NoOp -move (ChangeURI u) model = model <# do - pushURI u - pure NoOp -move FetchComics model = model <# (SetComics <$> fetchComics) -move (SetComics cs) model = noEff model { appComics = cs } -move (ToggleAudio i ) model = model { cpAudioState = newState } <# do - el <- Document.getElementById i - toggle el - pure NoOp - where - (newState, toggle) = case cpAudioState model of - Playing -> (Paused, Audio.pause) - Paused -> (Playing, Audio.play) -move ToggleFullscreen model = model { cpState = newState } <# do - el <- Document.querySelector "body" - -- TODO: check Document.fullscreenEnabled - -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled - _ <- toggle el - pure NoOp - where - (toggle, newState) = case cpState model of - Reading Full c n -> (const Fullscreen.exit, Reading Full c n) - Reading Spread c n -> (Fullscreen.request, Reading Spread c n) - -- otherwise, do nothing: - x -> (pure, x) -move (SetMediaInfo x) model = model { dMediaInfo = x } <# do - case x of - Just Comic {comicId = id} -> - pure $ ScrollIntoView $ "comic-" <> ms id - Nothing -> - pure NoOp -move (ScrollIntoView id) model = model <# do - say $ ms $ Legacy.show id - scrollIntoView id - pure NoOp - -fetchComics :: IO (Network.RemoteData MisoString [Comic]) -fetchComics = do - mjson <- contents <$> xhrByteString req - case mjson of - Nothing -> - pure $ Network.Failure "Could not fetch comics from server." - Just json -> pure $ Network.fromEither - $ either (Left . ms) pure - $ eitherDecodeStrict json - where - req = Request - { reqMethod = GET - , reqURI = "/api/comic" -- FIXME: can we replace this hardcoding? - , reqLogin = Nothing - , reqHeaders = [] - , reqWithCredentials = False - , reqData = NoData - } diff --git a/Com/MusicMeetsComics/Apex.hs b/Com/MusicMeetsComics/Apex.hs deleted file mode 100644 index f652f68..0000000 --- a/Com/MusicMeetsComics/Apex.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Com.MusicMeetsComics.Apex where - -import qualified Clay -import Com.MusicMeetsComics.App -import qualified Com.MusicMeetsComics.Assets as Assets -import qualified Com.MusicMeetsComics.Database as Database -import qualified Com.MusicMeetsComics.Server.Config as Config -import qualified Com.MusicMeetsComics.Server.Init as Init -import qualified Com.MusicMeetsComics.Look as Look -import qualified Com.MusicMeetsComics.Look.Typography as Typography -import Data.Aeson -import Data.Proxy -import Data.Text ( Text ) -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Lazy.Encoding as Lazy -import GHC.Generics -import qualified Lucid as L -import Lucid.Base -import Miso -import Miso.String -import Network.HTTP.Media ((//), (/:)) -import Network.HTTP.Types hiding ( Header ) -import Network.Wai -import Network.Wai.Application.Static -import Protolude -import Servant - - -main :: IO () -main = do - db <- Database.load - Init.runApp (app db) - -app :: Database.ComicDB -> Config.Config -> Application -app db _ = serve - (Proxy @AllRoutes) - ( static - :<|> cssHandlers - :<|> jsonHandlers db - :<|> serverHandlers - :<|> pure heroManifest - :<|> Tagged handle404 - ) - where - static = serveDirectoryWith (defaultWebAppSettings "static") - - --- | HtmlPage for setting HTML doctype and header -newtype HtmlPage a = HtmlPage a - deriving (Show, Eq) - --- | Convert client side routes into server-side web handlers -type ServerRoutes = ToServerRoutes ClientRoutes HtmlPage Action - -type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic] - -type CssRoute = "css" :> "main.css" :> Get '[CSS] Text - -newtype CSS = CSS { unCSS :: Text } - -instance Accept CSS where - contentType _ = "text" // "css" /: ("charset", "utf-8") - -instance MimeRender CSS Text where - mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict - -cssHandlers :: Server CssRoute -cssHandlers = return . Lazy.toStrict . Clay.render - $ Typography.main <> Look.main - -type AllRoutes - = ("static" :> Raw) - :<|> CssRoute - :<|> JsonApi - :<|> ServerRoutes - :<|> ("manifest.json" :> Get '[JSON] Manifest) - :<|> Raw - -data Manifest = Manifest - { name :: Text - , short_name :: Text - , start_url :: Text - , display :: Text - , theme_color :: Text - , description :: Text - } deriving (Show, Eq, Generic) - -instance ToJSON Manifest - -heroManifest :: Manifest -heroManifest = Manifest { name = "Hero" - , short_name = "Hero" - , start_url = "." - , display = "standalone" - , theme_color = "#0a0a0a" - , description = "Comics for all" - } - -handle404 :: Application -handle404 _ respond = - respond - $ responseLBS status404 [("Content-Type", "text/html")] - $ renderBS - $ toHtml - $ HtmlPage - $ the404 - $ initModel homeLink - -instance L.ToHtml a => L.ToHtml (HtmlPage a) where - toHtmlRaw = L.toHtml - toHtml (HtmlPage x) = do - L.doctype_ - L.html_ [L.lang_ "en"] - $ do - L.head_ $ do - L.title_ "Hero [alpha]" - L.link_ [L.rel_ "manifest", L.href_ "/manifest.json"] - L.link_ [L.rel_ "icon", L.type_ ""] - - -- icons - L.link_ - [ L.rel_ "apple-touch-icon" - , L.sizes_ "180x180" - , L.href_ - $ Assets.cdnEdge - <> "/old-assets/images/favicons/apple-touch-icon.png" - ] - L.link_ - [ L.rel_ "icon" - , L.type_ "image/png" - , L.sizes_ "32x32" - , L.href_ $ Assets.cdnEdge <> "/old-assets/images/favicons/favicon-32x32.png" - ] - L.link_ - [ L.rel_ "icon" - , L.type_ "image/png" - , L.sizes_ "16x16" - , L.href_ $ Assets.cdnEdge <> "/old-assets/images/favicons/favicon-16x16.png" - ] - L.link_ - [ L.rel_ "manifest" - , L.href_ $ Assets.cdnEdge <> "/old-assets/images/favicons/manifest.json" - ] - L.link_ - [ L.rel_ "mask-icon" - , L.href_ - $ Assets.cdnEdge - <> "/old-assets/images/favicons/safari-pinned-tab.svg" - ] - - L.meta_ [L.charset_ "utf-8"] - L.meta_ [L.name_ "theme-color", L.content_ "#000"] - L.meta_ [L.httpEquiv_ "X-UA-Compatible", L.content_ "IE=edge"] - L.meta_ - [ L.name_ "viewport" - , L.content_ "width=device-width, initial-scale=1" - ] - cssRef animateRef - cssRef bulmaRef - cssRef fontAwesomeRef - cssRef "/css/main.css" -- TODO: make this a safeLink? - jsRef "/static/all.js" - jsRef "/static/usersnap.js" - L.body_ (L.toHtml x) - where - jsRef href = L.with - (L.script_ mempty) - [ makeAttribute "src" href - , makeAttribute "async" mempty - , makeAttribute "defer" mempty - ] - cssRef href = L.with - (L.link_ mempty) - [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] - -fontAwesomeRef :: MisoString -fontAwesomeRef = - "https://use.fontawesome.com/releases/v5.7.2/css/all.css" - -animateRef :: MisoString -animateRef = - "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css" - -bulmaRef :: MisoString -bulmaRef = - "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" - -serverHandlers :: Server ServerRoutes -serverHandlers = - homeHandler - :<|> comicCoverHandler - :<|> comicPageHandler - :<|> comicPageFullHandler - :<|> comicVideoHandler - :<|> loginHandler - :<|> discoverHandler - :<|> chooseExperienceHandler - -jsonHandlers :: Database.ComicDB -> Server JsonApi -jsonHandlers db = Database.getComics db - -homeHandler :: Handler (HtmlPage (View Action)) -homeHandler = pure . HtmlPage . home $ initModel homeLink - -comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action)) -comicCoverHandler id = pure . HtmlPage . comicCover id . initModel $ comicLink id - -comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) -comicPageHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n - -comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) -comicPageFullHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n - -comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) -comicVideoHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n - -loginHandler :: Handler (HtmlPage (View Action)) -loginHandler = pure . HtmlPage . login $ initModel loginLink - -discoverHandler :: Handler (HtmlPage (View Action)) -discoverHandler = pure . HtmlPage . discover $ initModel discoverLink - -chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) -chooseExperienceHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n diff --git a/Com/MusicMeetsComics/Client.hs b/Com/MusicMeetsComics/Client.hs new file mode 100644 index 0000000..2dad3b7 --- /dev/null +++ b/Com/MusicMeetsComics/Client.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Com.MusicMeetsComics.Client where + +import Com.MusicMeetsComics.App ( Action(..) + , Comic(..) + , ComicReaderState(..) + , ComicReaderView(..) + , Model(..) + , AudioState(..) + , audioId + , chooseExperienceLink + , comicPlayerSpreadLink + , comicPlayerFullLink + , comicVideoLink + , handlers + , initModel + , the404 + , routes + ) +import qualified Com.Simatime.Network as Network +import Data.Aeson ( eitherDecodeStrict ) +import qualified Data.Set as Set +import qualified GHC.Show as Legacy +import JavaScript.Web.XMLHttpRequest ( Request(..) + , Method(GET) + , RequestData(NoData) + , contents + , xhrByteString + ) +import Miso +import Miso.Effect.DOM (scrollIntoView) +import qualified Miso.FFI.Audio as Audio +import qualified Miso.FFI.Document as Document +import qualified Miso.FFI.Fullscreen as Fullscreen +import Miso.String +import Protolude + +-- | Entry point for a miso application +main :: IO () +main = miso $ \currentURI -> App { model = initModel currentURI, .. } + where + update = move + view = see + subs = [ uriSub HandleURI + , keyboardSub keynav + ] + events = defaultEvents + initialAction = FetchComics + mountPoint = Nothing + +(∈) :: Ord a => a -> Set a -> Bool +(∈) = Set.member + +-- | Keyboard navigation - maps keys to actions. +keynav :: Set Int -> Action +keynav ks + | 37 ∈ ks = PrevPage -- ^ left arrow + | 39 ∈ ks = NextPage -- ^ right arrow + | 191 ∈ ks = DumpModel -- ^ ? + | 32 ∈ ks = ToggleAudio audioId -- ^ SPC + | otherwise = NoOp + +see :: Model -> View Action +see model = + case runRoute routes handlers uri model of + Left _ -> the404 model + Right v -> v + +-- | Console-logging +foreign import javascript unsafe "console.log($1);" + say :: MisoString -> IO () + +-- | Updates model, optionally introduces side effects +move :: Action -> Model -> Effect Action Model +move NoOp model = noEff model +move DumpModel model = model <# do + say $ ms $ Legacy.show model + pure NoOp +move (SelectExperience comic) model = model { cpState = ChooseExperience (comicId comic) 1 } + <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 +move (StartReading comic) model = model { cpState = Reading Spread (comicId comic) 1 } + <# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1 +move (StartWatching comic) model = model { cpState = Watching (comicId comic) } + <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 +move NextPage model = case cpState model of + Reading Spread id pg -> + model { cpState = Reading Spread id (pg+2) } <# do + pure $ ChangeURI $ comicPlayerSpreadLink id (pg+2) + Reading Full id pg -> + model { cpState = Reading Full id (pg+1) } <# do + pure $ ChangeURI $ comicPlayerFullLink id (pg+1) + Cover id -> + model { cpState = Reading Spread id 1 } <# do + pure $ ChangeURI $ comicPlayerSpreadLink id 1 + _ -> noEff model +move PrevPage model = case cpState model of + Reading Spread id pg -> + model { cpState = Reading Spread id (pg-2) } <# do + pure $ ChangeURI $ comicPlayerSpreadLink id (pg-2) + Reading Full id pg -> + model { cpState = Reading Full id (pg-1) } <# do + pure $ ChangeURI $ comicPlayerFullLink id (pg-1) + Cover _ -> noEff model + _ -> noEff model +move (ToggleZoom c pg) m = m { cpState = newState } <# do pure act + where + goto lnk = ChangeURI $ lnk (comicId c) pg + reading v = Reading v (comicId c) pg + (newState, act) = case cpState m of + Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink) + Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink) + x -> (x, NoOp) +move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp + where + newLib | c `elem` (userLibrary model) = + Protolude.filter (/= c) $ userLibrary model + | otherwise = c : (userLibrary model) +move (HandleURI u) model = model { uri = u } <# pure NoOp +move (ChangeURI u) model = model <# do + pushURI u + pure NoOp +move FetchComics model = model <# (SetComics <$> fetchComics) +move (SetComics cs) model = noEff model { appComics = cs } +move (ToggleAudio i ) model = model { cpAudioState = newState } <# do + el <- Document.getElementById i + toggle el + pure NoOp + where + (newState, toggle) = case cpAudioState model of + Playing -> (Paused, Audio.pause) + Paused -> (Playing, Audio.play) +move ToggleFullscreen model = model { cpState = newState } <# do + el <- Document.querySelector "body" + -- TODO: check Document.fullscreenEnabled + -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled + _ <- toggle el + pure NoOp + where + (toggle, newState) = case cpState model of + Reading Full c n -> (const Fullscreen.exit, Reading Full c n) + Reading Spread c n -> (Fullscreen.request, Reading Spread c n) + -- otherwise, do nothing: + x -> (pure, x) +move (SetMediaInfo x) model = model { dMediaInfo = x } <# do + case x of + Just Comic {comicId = id} -> + pure $ ScrollIntoView $ "comic-" <> ms id + Nothing -> + pure NoOp +move (ScrollIntoView id) model = model <# do + say $ ms $ Legacy.show id + scrollIntoView id + pure NoOp + +fetchComics :: IO (Network.RemoteData MisoString [Comic]) +fetchComics = do + mjson <- contents <$> xhrByteString req + case mjson of + Nothing -> + pure $ Network.Failure "Could not fetch comics from server." + Just json -> pure $ Network.fromEither + $ either (Left . ms) pure + $ eitherDecodeStrict json + where + req = Request + { reqMethod = GET + , reqURI = "/api/comic" -- FIXME: can we replace this hardcoding? + , reqLogin = Nothing + , reqHeaders = [] + , reqWithCredentials = False + , reqData = NoData + } diff --git a/Com/MusicMeetsComics/Server.hs b/Com/MusicMeetsComics/Server.hs new file mode 100644 index 0000000..7bb94a2 --- /dev/null +++ b/Com/MusicMeetsComics/Server.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Com.MusicMeetsComics.Server where + +import qualified Clay +import Com.MusicMeetsComics.App +import qualified Com.MusicMeetsComics.Assets as Assets +import qualified Com.MusicMeetsComics.Database as Database +import qualified Com.MusicMeetsComics.Server.Config as Config +import qualified Com.MusicMeetsComics.Server.Init as Init +import qualified Com.MusicMeetsComics.Look as Look +import qualified Com.MusicMeetsComics.Look.Typography as Typography +import Data.Aeson +import Data.Proxy +import Data.Text ( Text ) +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy +import GHC.Generics +import qualified Lucid as L +import Lucid.Base +import Miso +import Miso.String +import Network.HTTP.Media ((//), (/:)) +import Network.HTTP.Types hiding ( Header ) +import Network.Wai +import Network.Wai.Application.Static +import Protolude +import Servant + + +main :: IO () +main = do + db <- Database.load + Init.runApp (app db) + +app :: Database.ComicDB -> Config.Config -> Application +app db _ = serve + (Proxy @AllRoutes) + ( static + :<|> cssHandlers + :<|> jsonHandlers db + :<|> serverHandlers + :<|> pure heroManifest + :<|> Tagged handle404 + ) + where + static = serveDirectoryWith (defaultWebAppSettings "static") + + +-- | HtmlPage for setting HTML doctype and header +newtype HtmlPage a = HtmlPage a + deriving (Show, Eq) + +-- | Convert client side routes into server-side web handlers +type ServerRoutes = ToServerRoutes ClientRoutes HtmlPage Action + +type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic] + +type CssRoute = "css" :> "main.css" :> Get '[CSS] Text + +newtype CSS = CSS { unCSS :: Text } + +instance Accept CSS where + contentType _ = "text" // "css" /: ("charset", "utf-8") + +instance MimeRender CSS Text where + mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict + +cssHandlers :: Server CssRoute +cssHandlers = return . Lazy.toStrict . Clay.render + $ Typography.main <> Look.main + +type AllRoutes + = ("static" :> Raw) + :<|> CssRoute + :<|> JsonApi + :<|> ServerRoutes + :<|> ("manifest.json" :> Get '[JSON] Manifest) + :<|> Raw + +data Manifest = Manifest + { name :: Text + , short_name :: Text + , start_url :: Text + , display :: Text + , theme_color :: Text + , description :: Text + } deriving (Show, Eq, Generic) + +instance ToJSON Manifest + +heroManifest :: Manifest +heroManifest = Manifest { name = "Hero" + , short_name = "Hero" + , start_url = "." + , display = "standalone" + , theme_color = "#0a0a0a" + , description = "Comics for all" + } + +handle404 :: Application +handle404 _ respond = + respond + $ responseLBS status404 [("Content-Type", "text/html")] + $ renderBS + $ toHtml + $ HtmlPage + $ the404 + $ initModel homeLink + +instance L.ToHtml a => L.ToHtml (HtmlPage a) where + toHtmlRaw = L.toHtml + toHtml (HtmlPage x) = do + L.doctype_ + L.html_ [L.lang_ "en"] + $ do + L.head_ $ do + L.title_ "Hero [alpha]" + L.link_ [L.rel_ "manifest", L.href_ "/manifest.json"] + L.link_ [L.rel_ "icon", L.type_ ""] + + -- icons + L.link_ + [ L.rel_ "apple-touch-icon" + , L.sizes_ "180x180" + , L.href_ + $ Assets.cdnEdge + <> "/old-assets/images/favicons/apple-touch-icon.png" + ] + L.link_ + [ L.rel_ "icon" + , L.type_ "image/png" + , L.sizes_ "32x32" + , L.href_ $ Assets.cdnEdge <> "/old-assets/images/favicons/favicon-32x32.png" + ] + L.link_ + [ L.rel_ "icon" + , L.type_ "image/png" + , L.sizes_ "16x16" + , L.href_ $ Assets.cdnEdge <> "/old-assets/images/favicons/favicon-16x16.png" + ] + L.link_ + [ L.rel_ "manifest" + , L.href_ $ Assets.cdnEdge <> "/old-assets/images/favicons/manifest.json" + ] + L.link_ + [ L.rel_ "mask-icon" + , L.href_ + $ Assets.cdnEdge + <> "/old-assets/images/favicons/safari-pinned-tab.svg" + ] + + L.meta_ [L.charset_ "utf-8"] + L.meta_ [L.name_ "theme-color", L.content_ "#000"] + L.meta_ [L.httpEquiv_ "X-UA-Compatible", L.content_ "IE=edge"] + L.meta_ + [ L.name_ "viewport" + , L.content_ "width=device-width, initial-scale=1" + ] + cssRef animateRef + cssRef bulmaRef + cssRef fontAwesomeRef + cssRef "/css/main.css" -- TODO: make this a safeLink? + jsRef "/static/all.js" + jsRef "/static/usersnap.js" + L.body_ (L.toHtml x) + where + jsRef href = L.with + (L.script_ mempty) + [ makeAttribute "src" href + , makeAttribute "async" mempty + , makeAttribute "defer" mempty + ] + cssRef href = L.with + (L.link_ mempty) + [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] + +fontAwesomeRef :: MisoString +fontAwesomeRef = + "https://use.fontawesome.com/releases/v5.7.2/css/all.css" + +animateRef :: MisoString +animateRef = + "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css" + +bulmaRef :: MisoString +bulmaRef = + "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" + +serverHandlers :: Server ServerRoutes +serverHandlers = + homeHandler + :<|> comicCoverHandler + :<|> comicPageHandler + :<|> comicPageFullHandler + :<|> comicVideoHandler + :<|> loginHandler + :<|> discoverHandler + :<|> chooseExperienceHandler + +jsonHandlers :: Database.ComicDB -> Server JsonApi +jsonHandlers db = Database.getComics db + +homeHandler :: Handler (HtmlPage (View Action)) +homeHandler = pure . HtmlPage . home $ initModel homeLink + +comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action)) +comicCoverHandler id = pure . HtmlPage . comicCover id . initModel $ comicLink id + +comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicPageHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n + +comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicPageFullHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n + +comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicVideoHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n + +loginHandler :: Handler (HtmlPage (View Action)) +loginHandler = pure . HtmlPage . login $ initModel loginLink + +discoverHandler :: Handler (HtmlPage (View Action)) +discoverHandler = pure . HtmlPage . discover $ initModel discoverLink + +chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +chooseExperienceHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n diff --git a/Com/Simatime/buildGhc.nix b/Com/Simatime/buildGhc.nix new file mode 100644 index 0000000..489651e --- /dev/null +++ b/Com/Simatime/buildGhc.nix @@ -0,0 +1,54 @@ + +nixpkgs: + +{ name # the main module namespace +, nick # a short name, for the executable +, deps # deps get passed to ghc +}: + +with nixpkgs; + +let + nsToPath = ns: builtins.toString (builtins.replaceStrings ["."] ["/"] ns); + + path = nsToPath name; + + depsToPackageSet = packageSet: deps: + map (s: builtins.getAttr s packageSet) deps; + + claySrc = pkgs.fetchFromGitHub { + owner = "sebastiaanvisser"; + repo = "clay"; + rev = "cc7729b1b42a79e261091ff7835f7fc2a7ae3cee"; + sha256 = "1vd67976lvi5l4qq18zy6j44apynkl44ps04p8vwfx4gzr895dyp"; + }; + + ghc865_ = pkgs.haskell.packages.ghc865.override (oldAttrs: { + overrides = with pkgs.haskell.lib; self: super: { + clay = self.callCabal2nix "clay" claySrc {}; + wai-middleware-metrics = dontCheck super.wai-middleware-metrics; + }; + }); + + ghc = ghc865_.ghcWithPackages (hp: depsToPackageSet hp deps); + +in stdenv.mkDerivation { + name = name; + version = "0"; + src = ../../.; # this is the git root + nativeBuildInputs = [ ghc ]; + strictDeps = true; + buildPhase = '' + # + mkdir -p $out/{bin,static} ${path} + # + # compile with ghc + # + ${ghc}/bin/ghc -Werror -i. \ + --make ${path}.hs \ + -main-is ${name} \ + -o $out/bin/${nick} + ''; + # the install process was handled above + installPhase = "exit 0"; +} // { env = ghc; } diff --git a/Com/Simatime/buildGhcjs.nix b/Com/Simatime/buildGhcjs.nix new file mode 100644 index 0000000..0a88ce7 --- /dev/null +++ b/Com/Simatime/buildGhcjs.nix @@ -0,0 +1,64 @@ + +nixpkgs: + +{ name # the main module namespace +, nick # a short name for the output +, deps # passed to ghcjs +}: + +with nixpkgs; + +let + nsToPath = ns: builtins.toString (builtins.replaceStrings ["."] ["/"] ns); + + path = nsToPath name; + + depsToPackageSet = packageSet: deps: + map (s: builtins.getAttr s packageSet) deps; + + claySrc = pkgs.fetchFromGitHub { + owner = "sebastiaanvisser"; + repo = "clay"; + rev = "cc7729b1b42a79e261091ff7835f7fc2a7ae3cee"; + sha256 = "1vd67976lvi5l4qq18zy6j44apynkl44ps04p8vwfx4gzr895dyp"; + }; + + # ghcjs-8.6.0.1 + ghcjs_ = pkgs.haskell.packages.ghcjs.override (oldAttrs: { + overrides = with pkgs.haskell.lib; self: super: { + clay = dontCheck (self.callCabal2nix "clay" claySrc {}); + http-types = dontCheck super.http-types; + tasty-quickcheck = dontCheck super.tasty-quickcheck; + scientific = dontCheck super.scientific; # takes forever + servant = dontCheck super.servant; + comonad = dontCheck super.comonad; + QuickCheck = dontCheck super.QuickCheck; + }; + }); + + ghcjs = ghcjs_.ghcWithPackages (hp: depsToPackageSet hp deps); + +in stdenv.mkDerivation { + name = name; + version = "0"; + src = ../../.; # the git root + nativeBuildInputs = [ ghcjs ]; + strictDeps = true; + buildPhase = '' + # + mkdir -p $out/{bin,static} ${path} + # + # compile with ghcjs + # + ${ghcjs}/bin/ghcjs -Werror -i. \ + --make ${path}.hs \ + -main-is ${name} \ + -o ${path} + # + # optimize js output + # + ${pkgs.closurecompiler}/bin/closure-compiler \ + ${path}.jsexe/all.js > $out/static/${nick}.js + ''; + installPhase = "exit 0"; +} // { env = ghcjs; } diff --git a/Com/Simatime/buildHaskellApp.nix b/Com/Simatime/buildHaskellApp.nix deleted file mode 100644 index c7bdd1f..0000000 --- a/Com/Simatime/buildHaskellApp.nix +++ /dev/null @@ -1,90 +0,0 @@ - -nixpkgs: - -{ name # the namespace -, nick # a short name, for the executable -, deps # deps get passed to the compilers -}: - -with nixpkgs; - -let - nsToPath = ns: builtins.toString (builtins.replaceStrings ["."] ["/"] ns); - pathToNs = p: builtins.replaceStrings ["/"] ["."] p; - basePath = nsToPath name; - apexPath = basePath + "/Apex"; # compiled with ghc - aeroPath = basePath + "/Aero"; # compiled with ghcjs - - depsToPackageSet = packageSet: deps: - map (s: builtins.getAttr s packageSet) deps; - - claySrc = pkgs.fetchFromGitHub { - owner = "sebastiaanvisser"; - repo = "clay"; - rev = "cc7729b1b42a79e261091ff7835f7fc2a7ae3cee"; - sha256 = "1vd67976lvi5l4qq18zy6j44apynkl44ps04p8vwfx4gzr895dyp"; - }; - - ghc865_ = pkgs.haskell.packages.ghc865.override (oldAttrs: { - overrides = with pkgs.haskell.lib; self: super: { - clay = self.callCabal2nix "clay" claySrc {}; - wai-middleware-metrics = dontCheck super.wai-middleware-metrics; - }; - }); - - ghc = ghc865_.ghcWithPackages (hp: depsToPackageSet hp - (deps.both ++ deps.apex)); - - # ghcjs-8.6.0.1 - ghcjs_ = pkgs.haskell.packages.ghcjs.override (oldAttrs: { - overrides = with pkgs.haskell.lib; self: super: { - clay = dontCheck (self.callCabal2nix "clay" claySrc {}); - http-types = dontCheck super.http-types; - tasty-quickcheck = dontCheck super.tasty-quickcheck; - scientific = dontCheck super.scientific; # takes forever - servant = dontCheck super.servant; - comonad = dontCheck super.comonad; - QuickCheck = dontCheck super.QuickCheck; - }; - }); - - ghcjs = ghcjs_.ghcWithPackages (hp: - depsToPackageSet hp (deps.both ++ deps.aero)); - -in { - inherit ghc ghcjs; - app = stdenv.mkDerivation { - name = name; - version = "0"; - src = ../../.; # this is the git root - nativeBuildInputs = [ - ghc ghcjs guile - ]; - strictDeps = true; - buildPhase = '' - # - mkdir -p $out/{bin,static} ${basePath} - # - # compile with ghc - # - ${ghc}/bin/ghc -Werror -i. \ - --make ${apexPath}.hs \ - -main-is ${pathToNs apexPath} \ - -o $out/bin/${nick} - # - # compile with ghcjs - # - ${ghcjs}/bin/ghcjs -Werror -i. \ - --make ${aeroPath}.hs \ - -main-is ${pathToNs aeroPath} \ - -o ${aeroPath} - # - # optimize js output - # - ${pkgs.closurecompiler}/bin/closure-compiler \ - ${aeroPath}.jsexe/all.js > $out/static/${nick}.js - ''; - # the install process was handled above - installPhase = "exit 0"; - }; -} diff --git a/README.md b/README.md index fc9d918..d8ced5b 100644 --- a/README.md +++ b/README.md @@ -72,7 +72,7 @@ To build code, do: To get in the environment for a thing, use `nix run`. For example, if you want `ghci` with packages for `ibb`, do this: - nix run -f default.nix Com.InfluencedByBooks.ghc && ghci + nix run -f default.nix Com.InfluencedByBooks.Server.env && ghci And to deploy: diff --git a/default.nix b/default.nix index a05d370..4d2fbd2 100644 --- a/default.nix +++ b/default.nix @@ -5,7 +5,8 @@ let # TODO(bsima): buildNixOS should be split into multiple functions that each # return one thing, instead of a single function that returns multiple things buildOS = import ./Com/Simatime/buildOS.nix nixos; - buildHaskellApp = import ./Com/Simatime/buildHaskellApp.nix nixpkgs; + buildGhc = import ./Com/Simatime/buildGhc.nix nixpkgs; + buildGhcjs = import ./Com/Simatime/buildGhcjs.nix nixpkgs; nixos-mailserver = let ver = "v2.3.0"; in builtins.fetchTarball { url = "https://gitlab.com/simple-nixos-mailserver/nixos-mailserver/-/archive/${ver}/nixos-mailserver-${ver}.tar.gz"; sha256 = "0lpz08qviccvpfws2nm83n7m2r8add2wvfg9bljx9yxx8107r919"; @@ -69,18 +70,16 @@ in { boot.isContainer = true; networking.useDHCP = false; }; - } // (buildHaskellApp { - name = "Com.InfluencedByBooks"; - nick = "ibb"; - deps = { - both = [ + } // { + Server = buildGhc { + name = "Com.InfluencedByBooks.Server"; + nick = "ibb"; + deps = [ "clay" "miso" "protolude" "servant" "text" - ]; - apex = [ "MonadRandom" "acid-state" "blaze-html" @@ -93,18 +92,27 @@ in { "servant-server" "text" ]; - aero = [ + }; + Client = buildGhcjs { + name = "Com.InfluencedByBooks.Client"; + nick = "ibb"; + deps = [ + "clay" + "miso" + "protolude" + "servant" + "text" "aeson" "containers" "ghcjs-base" ]; }; - }); - Com.MusicMeetsComics = buildHaskellApp { - name = "Com.MusicMeetsComics"; - nick = "mmc"; - deps = { - both = [ + }; + Com.MusicMeetsComics = { + Server = buildGhc { + name = "Com.MusicMeetsComics.Server"; + nick = "mmc"; + deps = [ "aeson" "clay" "containers" @@ -114,8 +122,6 @@ in { "split" "string-quote" "text" - ]; - apex = [ "dhall" "ekg" "fast-logger" @@ -136,7 +142,20 @@ in { "wai-middleware-metrics" "warp" ]; - aero = [ + }; + Client = buildGhcjs { + name = "Com.MusicMeetsComics.Client"; + nick = "mmc"; + deps = [ + "aeson" + "clay" + "containers" + "miso" + "protolude" + "servant" + "split" + "string-quote" + "text" "ghcjs-base" ]; }; diff --git a/ghci b/ghci index be1cd94..0797ce5 100755 --- a/ghci +++ b/ghci @@ -1,2 +1,2 @@ #!/usr/bin/env bash -nix run -f default.nix "$@.ghc" -c ghci +nix run -f default.nix "$@.env" -c ghci -- cgit v1.2.3