From 46a680f7ca7def264a0f0b616883fb8e47271bab Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sun, 12 Apr 2020 12:15:49 -0700 Subject: De-namespace Alpha A bunch of formatting changes got in there too. Oops. I will probably eventually de-namespace everything, mostly because I'm tired of typing "Com.Whatever.Thing" all the time. A better namespacing strategy might be to use normal Haskell namespacing (Data, Control, Network, etc) for code that is not specific to biz activities (i.e. if I could open-source it at any time), and use simply "Biz" for stuff that I would never want to open-source. --- Alpha.hs | 87 +++++++++++++++++++ Com/InfluencedByBooks/Client.hs | 28 +++--- Com/InfluencedByBooks/Core.hs | 102 ++++++++++++---------- Com/InfluencedByBooks/Look.hs | 34 ++++---- Com/InfluencedByBooks/Move.hs | 57 +++++++------ Com/InfluencedByBooks/Server.hs | 147 ++++++++++++++++---------------- Com/MusicMeetsComics/App.hs | 2 +- Com/MusicMeetsComics/Look/Typography.hs | 2 +- Com/Simatime/Alpha.hs | 83 ------------------ Com/Simatime/Go.hs | 2 +- Run/Que/Server.hs | 4 +- Run/Que/Website.hs | 2 +- 12 files changed, 290 insertions(+), 260 deletions(-) create mode 100644 Alpha.hs delete mode 100644 Com/Simatime/Alpha.hs diff --git a/Alpha.hs b/Alpha.hs new file mode 100644 index 0000000..fe5c9df --- /dev/null +++ b/Alpha.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | Commonly useful functions, a Prelude replacement. +-- +-- This is designed to be imported everywhere, unqualified (generally +-- the only unqualified import you should use). +-- +-- Alpha can be opinionated and break with other Haskell idioms. For +-- example, we define our own operators which have a pattern to their +-- characters: +-- +-- - `|` normal function-level applications +-- - `/` indicates doing something inside a functor +-- - `<` and `>` indicate the direction in which values flow +-- between functions +-- +-- It seems unnecessarily different at first but it makes things easier +-- to read quickly. +module Alpha + ( + -- * Re-export Protolude + module X + -- * Applying + , (<|) + , (|>) + -- * Mapping + , (/>) + , () ) +import Data.String +import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import Protolude as X + +-- | Debugging printf +say :: Text -> IO () +say msg = putStrLn msg + +-- | Alias for map, fmap, <$> +( (a -> b) -> f a -> f b +( (a -> b) -> f0 (f1 a) -> f0 (f1 b) +( b) -> a -> b +(<|) = ($) +infixr 0 <| + +-- | Reverse function application. Do the left side, then pass the +-- return value to the function on the right side. +(|>) :: a -> (a -> b) -> b +(|>) = (&) + +-- | Alias for <&>. Can be read as "and then". Basically does into a +-- functor, does some computation, then returns the same kind of +-- functor. Could also be defined as `f >>= return . g` +(/>) :: Functor f => f a -> (a -> b) -> f b +(/>) = (<&>) + +-- | Removes newlines from text. +chomp :: Text -> Text +chomp = Text.filter (/= '\n') + +-- | Removes newlines from lazy text. +lchomp :: LazyText.Text -> LazyText.Text +lchomp = LazyText.filter (/= '\n') + +-- | Join a list of things with a separator. +joinWith :: [a] -> [[a]] -> [a] +joinWith = intercalate diff --git a/Com/InfluencedByBooks/Client.hs b/Com/InfluencedByBooks/Client.hs index a7da344..8c70a04 100644 --- a/Com/InfluencedByBooks/Client.hs +++ b/Com/InfluencedByBooks/Client.hs @@ -16,17 +16,23 @@ -- : dep ghcjs-base 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) +import Alpha +import Com.InfluencedByBooks.Core ( Action(..) + , see + , init + ) +import Com.InfluencedByBooks.Move ( move ) +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 + where + initialAction = FetchPeople + update = move + view = see + events = defaultEvents + subs = [] + mountPoint = Nothing diff --git a/Com/InfluencedByBooks/Core.hs b/Com/InfluencedByBooks/Core.hs index 6984004..2b98914 100644 --- a/Com/InfluencedByBooks/Core.hs +++ b/Com/InfluencedByBooks/Core.hs @@ -7,16 +7,18 @@ -- | Main app logic module Com.InfluencedByBooks.Core where -import Com.Simatime.Alpha -import Com.Simatime.Network -import Data.Aeson hiding (Success) -import Data.Data (Data, Typeable) -import Data.Text (Text) -import GHC.Generics (Generic) -import Miso -import Miso.String -import Servant.API -import Servant.Links +import Alpha +import Com.Simatime.Network +import Data.Aeson hiding ( Success ) +import Data.Data ( Data + , Typeable + ) +import Data.Text ( Text ) +import GHC.Generics ( Generic ) +import Miso +import Miso.String +import Servant.API +import Servant.Links -- * entity data types @@ -79,51 +81,63 @@ handlers :: Model -> View Action handlers = home notfound :: View Action -notfound = div_ [] [ text "404" ] +notfound = div_ [] [text "404"] goHome :: URI -goHome = linkURI $ safeLink - (Proxy :: Proxy AppRoutes) - (Proxy :: Proxy Home) +goHome = linkURI $ safeLink (Proxy :: Proxy AppRoutes) (Proxy :: Proxy Home) see :: Model -> View Action -see m = div_ [ class_ "container mt-5" ] - [ div_ [ class_ "jumbotron" ] - [ h1_ [ class_ "display-4" ] [ text "Influenced by books" ] - , p_ [ class_ "lead" ] [ text "Influential people and the books that made them." ] - , p_ [ class_ "lead" ] - [ a_ [ href_ "http://eepurl.com/ghBFjv" ] - [ text "Get new book recommendations from the world's influencers in your email." ] - ] +see m = div_ + [class_ "container mt-5"] + [ div_ + [class_ "jumbotron"] + [ h1_ [class_ "display-4"] [text "Influenced by books"] + , p_ [class_ "lead"] + [text "Influential people and the books that made them."] + , p_ + [class_ "lead"] + [ a_ + [href_ "http://eepurl.com/ghBFjv"] + [ text + "Get new book recommendations from the world's influencers in your email." + ] ] - , div_ [ class_ "card-columns" ] $ case people m of - NotAsked -> [ text "Initializing..." ] - Loading -> [ text "Loading..." ] - Failure err -> [ text err ] - Success ps -> seePerson [text "Initializing..."] + Loading -> [text "Loading..."] + Failure err -> [text err] + Success ps -> seePerson View Action -seePerson person = div_ [ class_ "card" ] - [ div_ [ class_ "card-img" ] - [ img_ [ class_ "card-img img-fluid", src_ $ ms $ _pic person ]] - , div_ [ class_ "card-body" ] - [ h4_ [ class_ "card-title" ] [ text $ ms $ _name person ] - , h6_ [] [ a_ [ class_ "fab fa-twitter" - , href_ $ "https://twitter.com/" <> (ms $ _twitter person) ] [] - , a_ [ class_ "fas fa-globe", href_ $ ms $ _website person ] [] - ] - , p_ [ class_ "card-text" ] - [ text $ ms $ _blurb person - , ul_ [] $ seeBook (ms $ _twitter person) + ] + [] + , a_ [class_ "fas fa-globe", href_ $ ms $ _website person] [] ] + , p_ [class_ "card-text"] + [text $ ms $ _blurb person, ul_ [] $ seeBook View Action -seeBook book = li_ [] - [ a_ [ class_ "text-dark" - , href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book) - ] - [ text $ ms $ _title book ] +seeBook book = li_ + [] + [ a_ + [ class_ "text-dark" + , href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book) + ] + [text $ ms $ _title book] ] diff --git a/Com/InfluencedByBooks/Look.hs b/Com/InfluencedByBooks/Look.hs index acc9e34..d904d3a 100644 --- a/Com/InfluencedByBooks/Look.hs +++ b/Com/InfluencedByBooks/Look.hs @@ -2,14 +2,14 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | The look and feel of Ibb -module Com.InfluencedByBooks.Look where +module Com.InfluencedByBooks.Look where +import Alpha hiding ( Selector ) import Clay -import qualified Clay.Flexbox as Flexbox -import qualified Clay.Media as Media -import qualified Clay.Render as Clay -import qualified Clay.Stylesheet as Stylesheet -import Com.Simatime.Alpha hiding (Selector) +import qualified Clay.Flexbox as Flexbox +import qualified Clay.Media as Media +import qualified Clay.Render as Clay +import qualified Clay.Stylesheet as Stylesheet main :: Css main = do @@ -25,18 +25,16 @@ main = do display flex justifyContent center flexDirection column - fontFamily [ "GillSans" - , "Calibri" - , "Trebuchet" - ] [sansSerif] + fontFamily ["GillSans", "Calibri", "Trebuchet"] [sansSerif] headings ? do - fontFamily [ "Palatino" - , "Palatino Linotype" - , "Hoefler Text" - , "Times New Roman" - , "Times" - ] [serif] + fontFamily + [ "Palatino" + , "Palatino Linotype" + , "Hoefler Text" + , "Times New Roman" + , "Times" + ] + [serif] headings :: Selector -headings = - h1 <> h2 <> h3 <> h4 <> h5 <> h6 +headings = h1 <> h2 <> h3 <> h4 <> h5 <> h6 diff --git a/Com/InfluencedByBooks/Move.hs b/Com/InfluencedByBooks/Move.hs index d6cb12e..5d6f0c4 100644 --- a/Com/InfluencedByBooks/Move.hs +++ b/Com/InfluencedByBooks/Move.hs @@ -2,25 +2,32 @@ {-# LANGUAGE OverloadedStrings #-} -- | App update logic -module Com.InfluencedByBooks.Move ( - move +module Com.InfluencedByBooks.Move + ( move -- * Server interactions , fetchPeople - ) where + ) +where -import Com.InfluencedByBooks.Core as Core -import Com.Simatime.Alpha -import Com.Simatime.Network -import Data.Aeson -import JavaScript.Web.XMLHttpRequest (Request(..), Method(GET), RequestData(NoData), contents, xhrByteString) -import Miso -import Miso.String +import Alpha +import Com.InfluencedByBooks.Core as Core +import Com.Simatime.Network +import Data.Aeson +import JavaScript.Web.XMLHttpRequest ( Request(..) + , Method(GET) + , RequestData(NoData) + , contents + , xhrByteString + ) +import Miso +import Miso.String move :: Action -> Model -> Effect Action Model -move Nop m = noEff m +move Nop m = noEff m move (HandleRoute u) m = m { uri = u } <# pure Nop -move (ChangeRoute u) m = m <# do pushURI u >> pure Nop -move FetchPeople m = m <# (SetPeople > pure Nop +move FetchPeople m = m <# (SetPeople pure $ Failure "could not read from server" - Just a -> pure - $ fromEither - $ either (Left . ms) pure - $ eitherDecodeStrict a - where - req = Request { reqMethod = GET - -- FIXME: can replace this hardcoding with a function? - , reqURI = "/api/people" - , reqLogin = Nothing - , reqHeaders = [] - , reqWithCredentials = False - , reqData = NoData - } + Just a -> + pure $ fromEither $ either (Left . ms) pure $ eitherDecodeStrict a + where + req = Request { reqMethod = GET + -- FIXME: can replace this hardcoding with a function? + , reqURI = "/api/people" + , reqLogin = Nothing + , reqHeaders = [] + , reqWithCredentials = False + , reqData = NoData + } diff --git a/Com/InfluencedByBooks/Server.hs b/Com/InfluencedByBooks/Server.hs index 28a7471..244a7ca 100644 --- a/Com/InfluencedByBooks/Server.hs +++ b/Com/InfluencedByBooks/Server.hs @@ -27,21 +27,23 @@ -- : dep text module Com.InfluencedByBooks.Server where +import Alpha 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 qualified Com.InfluencedByBooks.Keep as Keep +import qualified Com.InfluencedByBooks.Look as Look 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 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.Media ( (//) + , (/:) + ) import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Static @@ -49,58 +51,57 @@ import Network.Wai.Handler.Warp import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.RequestLogger import Servant -import System.Environment (lookupEnv) +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/" + 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 } + 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] + 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 } +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 @@ -111,39 +112,41 @@ instance Accept CSS where type CssRoute = "css" :> "main.css" :> Get '[CSS] Text type Routes - = "static" :> Raw - :<|> CssRoute - :<|> ServerRoutes - :<|> "api" :> ApiRoutes - :<|> Raw + = "static" + :> + Raw + :<|> + CssRoute + :<|> + ServerRoutes + :<|> + "api" + :> + ApiRoutes + :<|> + Raw cssHandlers :: Server CssRoute -cssHandlers = return . Lazy.toStrict . Clay.render - $ Look.main +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] +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 + 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 +apiHandlers keep = Acid.query' keep $ Keep.GetPeople 20 diff --git a/Com/MusicMeetsComics/App.hs b/Com/MusicMeetsComics/App.hs index 4c5f60a..3fa237d 100644 --- a/Com/MusicMeetsComics/App.hs +++ b/Com/MusicMeetsComics/App.hs @@ -10,11 +10,11 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Com.MusicMeetsComics.App where +import Alpha import qualified Clay import qualified Com.MusicMeetsComics.Assets as Assets import Com.MusicMeetsComics.Look as Look import Com.MusicMeetsComics.Look.Typography -import Com.Simatime.Alpha import Com.Simatime.Network import Data.Aeson ( ToJSON(..) , FromJSON(..) diff --git a/Com/MusicMeetsComics/Look/Typography.hs b/Com/MusicMeetsComics/Look/Typography.hs index 152662a..7f3b28d 100644 --- a/Com/MusicMeetsComics/Look/Typography.hs +++ b/Com/MusicMeetsComics/Look/Typography.hs @@ -3,10 +3,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Com.MusicMeetsComics.Look.Typography where +import Alpha import Clay import Clay.Stylesheet ( key ) import qualified Com.MusicMeetsComics.Assets as Assets -import Com.Simatime.Alpha import Data.Semigroup ( (<>) ) main :: Css diff --git a/Com/Simatime/Alpha.hs b/Com/Simatime/Alpha.hs deleted file mode 100644 index 7003cc5..0000000 --- a/Com/Simatime/Alpha.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} --- | Commonly useful functions, a Prelude replacement. -module Com.Simatime.Alpha - ( - -- * Re-export Protolude - module X - -- * Applying - , (<|) - , (|>) - -- * Mapping - , (/>) - , () ) -import Data.String -import Data.Text ( Text ) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText -import qualified Prelude -import Protolude as X - --- | Debugging printf -say :: Text -> IO () -say msg = putStrLn msg - --- $operators --- --- Operators have a pattern to their characters --- --- `|` normal function-level applications --- `/` indicates doing something inside a functor --- `<` and `>` indicate the direction in which values flow btw functions - --- | Alias for map, fmap, <$> -( (a -> b) -> f a -> f b -( (a -> b) -> f0 (f1 a) -> f0 (f1 b) -( b) -> a -> b -(<|) = ($) -infixr 0 <| - --- | Reverse function application. Do the left side, then pass the --- return value to the function on the right side. -(|>) :: a -> (a -> b) -> b -(|>) = (&) - --- | Alias for <&>. Can be read as "and then". Basically does into a --- functor, does some computation, then returns the same kind of --- functor. Could also be defined as `f >>= return . g` -(/>) :: Functor f => f a -> (a -> b) -> f b -(/>) = (<&>) - --- | Removes newlines from text. -chomp :: Text -> Text -chomp = Text.filter (/= '\n') - --- | Removes newlines from lazy text. -lchomp :: LazyText.Text -> LazyText.Text -lchomp = LazyText.filter (/= '\n') - --- | Join a list of things with a separator. -joinWith :: [a] -> [[a]] -> [a] -joinWith = intercalate diff --git a/Com/Simatime/Go.hs b/Com/Simatime/Go.hs index 9ea2896..01555f3 100644 --- a/Com/Simatime/Go.hs +++ b/Com/Simatime/Go.hs @@ -22,7 +22,7 @@ module Com.Simatime.Go ) where -import Com.Simatime.Alpha hiding ( read ) +import Alpha hiding ( read ) import qualified Control.Concurrent as Concurrent import qualified Control.Concurrent.Chan.Unagi.Bounded as Chan diff --git a/Run/Que/Server.hs b/Run/Que/Server.hs index 70bc559..e807502 100644 --- a/Run/Que/Server.hs +++ b/Run/Que/Server.hs @@ -20,7 +20,7 @@ module Run.Que.Server ) where -import Com.Simatime.Alpha hiding ( Text +import Alpha hiding ( Text , get , gets , modify @@ -147,7 +147,7 @@ routes = do app . modify <| upsertNamespace ns q <- app <| que ns qp qdata <- Scotty.body - _ <- liftIO <| Go.write q <| BSL.toStrict qdata + _ <- liftIO <| Go.write q <| BSL.toStrict qdata return () -- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist` diff --git a/Run/Que/Website.hs b/Run/Que/Website.hs index 7a551b8..52e46f9 100644 --- a/Run/Que/Website.hs +++ b/Run/Que/Website.hs @@ -17,8 +17,8 @@ module Run.Que.Website ) where +import Alpha import qualified Control.Concurrent.Async as Async -import Com.Simatime.Alpha import qualified Data.ByteString.Char8 as BS import qualified Data.Ini.Config as Config import qualified Data.Text as Text -- cgit v1.2.3