summaryrefslogtreecommitdiff
path: root/Biz
diff options
context:
space:
mode:
Diffstat (limited to 'Biz')
-rw-r--r--Biz/App.hs2
-rw-r--r--Biz/Auth.hs4
-rw-r--r--Biz/Bild/Deps/Haskell.nix1
-rw-r--r--Biz/Ibb/Client.hs2
-rw-r--r--Biz/Ibb/Core.hs69
-rw-r--r--Biz/Ibb/Influencers.hs14
-rw-r--r--Biz/Ibb/Keep.hs31
-rw-r--r--Biz/Ibb/Move.hs9
-rw-r--r--Biz/Ibb/Server.hs52
-rw-r--r--Biz/Pie.hs14
-rw-r--r--Biz/Que/Host.hs14
11 files changed, 105 insertions, 107 deletions
diff --git a/Biz/App.hs b/Biz/App.hs
index 5759499..5e66f71 100644
--- a/Biz/App.hs
+++ b/Biz/App.hs
@@ -29,7 +29,7 @@ instance Accept CSS where
contentType _ = "text" // "css" /: ("charset", "utf-8")
instance MimeRender CSS Text where
- mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
+ mimeRender _ = Lazy.encodeUtf8 <. Lazy.fromStrict
-- | The manifest describes your app for web app thumbnails, iPhone tiles, etc.
data Manifest = Manifest
diff --git a/Biz/Auth.hs b/Biz/Auth.hs
index 2f4d17a..3648395 100644
--- a/Biz/Auth.hs
+++ b/Biz/Auth.hs
@@ -2,7 +2,8 @@ module Biz.Auth
( Error (..),
Password,
Username,
- ) where
+ )
+where
import Data.ByteString (ByteString)
import Data.Text (Text)
@@ -13,4 +14,5 @@ data Error
| BadPassword
type Password = MisoString
+
type Username = MisoString
diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix
index 78ae6b2..1153e28 100644
--- a/Biz/Bild/Deps/Haskell.nix
+++ b/Biz/Bild/Deps/Haskell.nix
@@ -5,7 +5,6 @@
"aeson"
"async"
"bytestring"
- # "capability" # broken deps
"clay"
"cmark"
"config-ini"
diff --git a/Biz/Ibb/Client.hs b/Biz/Ibb/Client.hs
index d0ed3e3..efe4e84 100644
--- a/Biz/Ibb/Client.hs
+++ b/Biz/Ibb/Client.hs
@@ -29,7 +29,7 @@ import Miso
)
main :: IO ()
-main = miso $ \u -> App {model = init u, ..}
+main = miso <| \u -> App {model = init u, ..}
where
initialAction = FetchPeople
update = move
diff --git a/Biz/Ibb/Core.hs b/Biz/Ibb/Core.hs
index 007d835..ec6ef10 100644
--- a/Biz/Ibb/Core.hs
+++ b/Biz/Ibb/Core.hs
@@ -22,34 +22,32 @@ import Servant.Links
-- * entity data types
-data Person
- = Person
- { -- | Their full name.
- _name :: Text,
- -- | A link to their picture.
- _pic :: Text,
- -- | Their twitter handle, without the `@` prefix.
- _twitter :: Text,
- -- | Their main website, fully formed: `https://example.com`
- _website :: Text,
- -- | A short list of the books they recommend.
- _books :: [Book],
- -- | A short "about" section, like you would see on the jacket flap of a book.
- _blurb :: Text
- }
+data Person = Person
+ { -- | Their full name.
+ _name :: Text,
+ -- | A link to their picture.
+ _pic :: Text,
+ -- | Their twitter handle, without the `@` prefix.
+ _twitter :: Text,
+ -- | Their main website, fully formed: `https://example.com`
+ _website :: Text,
+ -- | A short list of the books they recommend.
+ _books :: [Book],
+ -- | A short "about" section, like you would see on the jacket flap of a book.
+ _blurb :: Text
+ }
deriving (Generic, Show, Eq, Typeable, Data, Ord)
instance FromJSON Person
instance ToJSON Person
-data Book
- = Book
- { _title :: Text,
- _author :: Text,
- -- | Amazon REF number, for creating affiliate links.
- _amznref :: Text
- }
+data Book = Book
+ { _title :: Text,
+ _author :: Text,
+ -- | Amazon REF number, for creating affiliate links.
+ _amznref :: Text
+ }
deriving (Generic, Show, Eq, Typeable, Data, Ord)
instance FromJSON Book
@@ -62,11 +60,10 @@ type AppRoutes = Home
type Home = View Action
-data Model
- = Model
- { uri :: URI,
- people :: WebData [Person]
- }
+data Model = Model
+ { uri :: URI,
+ people :: WebData [Person]
+ }
deriving (Show, Eq)
type WebData a = RemoteData MisoString a
@@ -92,7 +89,7 @@ notfound :: View Action
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 =
@@ -113,7 +110,7 @@ see m =
]
]
],
- div_ [class_ "card-columns"] $ case people m of
+ div_ [class_ "card-columns"] <| case people m of
NotAsked -> [text "Initializing..."]
Loading -> [text "Loading..."]
Failure err -> [text err]
@@ -126,22 +123,22 @@ seePerson person =
[class_ "card"]
[ div_
[class_ "card-img"]
- [img_ [class_ "card-img img-fluid", src_ $ ms $ _pic person]],
+ [img_ [class_ "card-img img-fluid", src_ <| ms <| _pic person]],
div_
[class_ "card-body"]
- [ h4_ [class_ "card-title"] [text $ ms $ _name person],
+ [ h4_ [class_ "card-title"] [text <| ms <| _name person],
h6_
[]
[ a_
[ class_ "fab fa-twitter",
- href_ $ "https://twitter.com/" <> ms (_twitter person)
+ href_ <| "https://twitter.com/" <> ms (_twitter person)
]
[],
- a_ [class_ "fas fa-globe", href_ $ ms $ _website person] []
+ a_ [class_ "fas fa-globe", href_ <| ms <| _website person] []
],
p_
[class_ "card-text"]
- [text $ ms $ _blurb person, ul_ [] $ seeBook </ _books person]
+ [text <| ms <| _blurb person, ul_ [] <| seeBook </ _books person]
]
]
@@ -151,7 +148,7 @@ seeBook book =
[]
[ a_
[ class_ "text-dark",
- href_ $ "https://www.amazon.com/dp/" <> ms (_amznref book)
+ href_ <| "https://www.amazon.com/dp/" <> ms (_amznref book)
]
- [text $ ms $ _title book]
+ [text <| ms <| _title book]
]
diff --git a/Biz/Ibb/Influencers.hs b/Biz/Ibb/Influencers.hs
index 08ce3e8..e41f5b1 100644
--- a/Biz/Ibb/Influencers.hs
+++ b/Biz/Ibb/Influencers.hs
@@ -81,7 +81,7 @@ allPeople =
{ _name = "Bill Gates",
_pic = "https://pbs.twimg.com/profile_images/988775660163252226/XpgonN0X_400x400.jpg",
_twitter = "BillGates",
- _blurb = "Sharing things I'm learning through my foundation work and other interests. Founder of Microsoft and Bill & Melinda Gates Foundation",
+ _blurb = "Sharing things I'm learning through my foundation work and other interests. Founder of Microsoft and Bill |> Melinda Gates Foundation",
_website = "https://www.gatesnotes.com",
_books =
[ Book
@@ -138,7 +138,7 @@ allPeople =
{ _name = "Susan Cain",
_pic = "https://pbs.twimg.com/profile_images/1474290079/SusanCain5smaller-1_400x400.jpg",
_twitter = "susancain",
- _blurb = "Bestselling author, award-winning speaker, http://Quietrev.com curator. Lover of bittersweet music & bittersweet chocolate, in equal measure.",
+ _blurb = "Bestselling author, award-winning speaker, http://Quietrev.com curator. Lover of bittersweet music |> bittersweet chocolate, in equal measure.",
_website = "https://www.quietrev.com",
_books =
[ Book
@@ -195,7 +195,7 @@ allPeople =
{ _name = "Luis Von Ahn",
_pic = "https://pbs.twimg.com/profile_images/1020343581087678464/NIXD5MdC_400x400.jpg",
_twitter = "LuisvonAhn",
- _blurb = "CEO & co-founder of duolingo. Invented reCAPTCHA. Computer science professor at Carnegie Mellon. Proud Guatemalan",
+ _blurb = "CEO |> co-founder of duolingo. Invented reCAPTCHA. Computer science professor at Carnegie Mellon. Proud Guatemalan",
_website = "https://www.duolingo.com/",
_books =
[ Book
@@ -271,7 +271,7 @@ allPeople =
{ _name = "Allen Walton",
_pic = "https://pbs.twimg.com/profile_images/1038905908678545409/yUbF9Ruc_400x400.jpg",
_twitter = "allenthird",
- _blurb = "Created http://SpyGuy.com and blogs about stuff at http://AllenWalton.com . All things ecommerce, personal dev, and Simpsons.",
+ _blurb = "Created http://SpyGuy.com and blogs about stuff at http://AllenWalton.com <. All things ecommerce, personal dev, and Simpsons.",
_website = "https://www.allenwalton.com",
_books =
[ Book
@@ -290,7 +290,7 @@ allPeople =
{ _name = "Peter Mallouk",
_pic = "https://pbs.twimg.com/profile_images/713172266968715264/KsyDYghf_400x400.jpg",
_twitter = "PeterMallouk",
- _blurb = "President of Creative Planning. Author “5 Mistakes Every Investor Makes & How to Avoid Them”. Radically moderate.",
+ _blurb = "President of Creative Planning. Author “5 Mistakes Every Investor Makes |> How to Avoid Them”. Radically moderate.",
_website = "https://creativeplanning.com",
_books =
[ Book
@@ -423,7 +423,7 @@ allPeople =
{ _name = "Robert Herjavec",
_pic = "https://pbs.twimg.com/profile_images/608643660876423170/DgxUW3eZ_400x400.jpg",
_twitter = "robertherjavec",
- _blurb = "Dad, Husband, Founder & CEO of global cybersecurity firm HerjavecGroup, Shark on ABC’s Shark Tank, Former Dragon, Author",
+ _blurb = "Dad, Husband, Founder |> CEO of global cybersecurity firm HerjavecGroup, Shark on ABC’s Shark Tank, Former Dragon, Author",
_website = "https://www.robertherjavec.com/",
_books =
[ Book
@@ -470,7 +470,7 @@ allPeople =
_amznref = "1585424331"
},
Book
- { _title = "How to Win Friends & Influence People",
+ { _title = "How to Win Friends |> Influence People",
_author = "Dale Carnegie",
_amznref = "0671027034"
}
diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs
index c7dabb0..074a42a 100644
--- a/Biz/Ibb/Keep.hs
+++ b/Biz/Ibb/Keep.hs
@@ -28,10 +28,9 @@ import qualified Data.Text as Text
-- * Keep
-- | Main database. Need to think of a better name for this.
-newtype IbbKeep
- = IbbKeep
- { _people :: IxSet Person
- }
+newtype IbbKeep = IbbKeep
+ { _people :: IxSet Person
+ }
deriving (Data, Typeable)
$(deriveSafeCopy 0 'base ''IbbKeep)
@@ -51,20 +50,20 @@ newtype PersonBlurb
instance Indexable Person where
empty =
ixSet
- [ ixFun $ \p -> [PersonName $ _name p],
- ixFun $ \p -> [_pic p],
- ixFun $ \p -> [_twitter p],
- ixFun $ \p -> [_website p],
- ixFun $ \p -> [_books p],
- ixFun $ \p -> [PersonBlurb $ _blurb p]
+ [ ixFun <| \p -> [PersonName <| _name p],
+ ixFun <| \p -> [_pic p],
+ ixFun <| \p -> [_twitter p],
+ ixFun <| \p -> [_website p],
+ ixFun <| \p -> [_books p],
+ ixFun <| \p -> [PersonBlurb <| _blurb p]
]
-- | updates the `IbbKeep` with a new `Person`
newPerson :: Text -> Text -> Update IbbKeep Person
newPerson name blurb = do
keep <- get
- put $
- k
+ put
+ <| k
{ _people = IxSet.insert p (_people k)
}
return p
@@ -97,16 +96,16 @@ newtype BookAuthor
instance Indexable Book where
empty =
ixSet
- [ ixFun $ \b -> [BookTitle $ _title b],
- ixFun $ \b -> [BookAuthor $ _author b],
- ixFun $ \b -> [_amznref b]
+ [ ixFun <| \b -> [BookTitle <| _title b],
+ ixFun <| \b -> [BookAuthor <| _author b],
+ ixFun <| \b -> [_amznref b]
]
-- | updates the `IbbKeep` with a new `Book`
-- newBook :: Text -> Text -> Text -> Update IbbKeep Book
-- newBook title author amznref = do
-- ibbKeep <- get
--- put $ ibbKeep { _books = IxSet.insert b (_books ibbKeep)
+-- put <| ibbKeep { _books = IxSet.insert b (_books ibbKeep)
-- , _people = _people ibbKeep
-- }
-- return b
diff --git a/Biz/Ibb/Move.hs b/Biz/Ibb/Move.hs
index 0dec4e5..2135f85 100644
--- a/Biz/Ibb/Move.hs
+++ b/Biz/Ibb/Move.hs
@@ -27,8 +27,9 @@ import Network.RemoteData
move :: Action -> Model -> Effect Action Model
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 (ChangeRoute u) m =
+ m <# do
+ pushURI u >> pure Nop
move FetchPeople m = m <# (SetPeople </ fetchPeople)
move (SetPeople ps) m = noEff m {people = ps}
@@ -36,9 +37,9 @@ fetchPeople :: IO (WebData [Core.Person])
fetchPeople = do
mjson <- contents </ xhrByteString req
case mjson of
- Nothing -> pure $ Failure "could not read from server"
+ Nothing -> pure <| Failure "could not read from server"
Just a ->
- pure $ fromEither $ either (Left . ms) pure $ eitherDecodeStrict a
+ pure <| fromEither <| either (Left <. ms) pure <| eitherDecodeStrict a
where
req =
Request
diff --git a/Biz/Ibb/Server.hs b/Biz/Ibb/Server.hs
index 058bbdc..3e4b662 100644
--- a/Biz/Ibb/Server.hs
+++ b/Biz/Ibb/Server.hs
@@ -56,10 +56,10 @@ main :: IO ()
main = do
say "rise: ibb"
staticDir <- fromMaybe "static" <$> lookupEnv "STATIC_DIR" :: IO String
- port <- (read . fromMaybe "3000" <$> lookupEnv "PORT") :: IO Int
+ port <- (read <. fromMaybe "3000" <$> lookupEnv "PORT") :: IO Int
keep <- Keep.openLocal "_/keep/"
say "port: 3000"
- run port $ logStdout $ compress $ app staticDir keep
+ run port <| logStdout <| compress <| app staticDir keep
where
compress = gzip def {gzipFiles = GzipCompress}
@@ -68,12 +68,13 @@ newtype HtmlPage a = HtmlPage a
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_ page
+ 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_ page
where
page = L.toHtml x
jsRef href =
@@ -94,18 +95,17 @@ type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action
handle404 :: Application
handle404 _ respond =
respond
- $ responseLBS status404 [("Content-Type", "text/html")]
- $ renderBS
- $ toHtml
- $ HtmlPage notfound
+ <| responseLBS status404 [("Content-Type", "text/html")]
+ <| renderBS
+ <| toHtml
+ <| HtmlPage notfound
-newtype CSS
- = CSS
- { unCSS :: Text
- }
+newtype CSS = CSS
+ { unCSS :: Text
+ }
instance MimeRender CSS Text where
- mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
+ mimeRender _ = Lazy.encodeUtf8 <. Lazy.fromStrict
instance Accept CSS where
contentType _ = "text" // "css" /: ("charset", "utf-8")
@@ -122,16 +122,16 @@ type Routes =
:<|> Raw
cssHandlers :: Server CssRoute
-cssHandlers = return . Lazy.toStrict . Clay.render $ Look.main
+cssHandlers = return <. Lazy.toStrict <. Clay.render <| Look.main
app :: String -> AcidState Keep.IbbKeep -> Application
app staticDir keep =
- serve (Proxy @Routes) $
- static
- :<|> cssHandlers
- :<|> serverHandlers
- :<|> apiHandlers keep
- :<|> Tagged handle404
+ serve (Proxy @Routes)
+ <| static
+ :<|> cssHandlers
+ :<|> serverHandlers
+ :<|> apiHandlers keep
+ :<|> Tagged handle404
where
static = serveDirectoryWith (defaultWebAppSettings staticDir)
@@ -140,9 +140,9 @@ type ApiRoutes = "people" :> Get '[JSON] [Person]
serverHandlers :: Server ServerRoutes
serverHandlers = homeHandler
where
- send f u = pure $ HtmlPage $ f Model {uri = u, people = NotAsked}
+ 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/Biz/Pie.hs b/Biz/Pie.hs
index d3fca5f..7df794f 100644
--- a/Biz/Pie.hs
+++ b/Biz/Pie.hs
@@ -70,18 +70,18 @@ main = do
addCommand
"new"
"start new a weekly sprint"
- (const . move New)
+ (const <. move New)
(pure mempty)
addCommand
"update"
"submit weekly update for a namespace"
- (move . Update)
- (optNamespace)
+ (move <. Update)
+ optNamespace
addCommand
"feedback"
"submit user feedback for a namespace"
- (move . Feedback)
- (optNamespace)
+ (move <. Feedback)
+ optNamespace
cwd <- Directory.getCurrentDirectory
root <- Env.getEnv "BIZ_ROOT"
let fullNamespace =
@@ -101,7 +101,7 @@ optNamespace =
<> short 'n'
<> value "Devalloc"
-data Form = Form {roll :: [Entry]}
+newtype Form = Form {roll :: [Entry]}
deriving (Generic, Aeson.ToJSON, Aeson.FromJSON, Show)
instance Monoid Form where
@@ -136,7 +136,7 @@ data Move
move :: Move -> Form -> IO Form
move mov form = case mov of
New -> do
- week <- Time.getCurrentTime >>= return . Time.formatTime Time.defaultTimeLocale "%V"
+ week <- Time.getCurrentTime >>= return <. Time.formatTime Time.defaultTimeLocale "%V"
let branch = "sprint-" <> week
proc <- Process.spawnProcess "git" ["show-ref", branch]
Process.waitForProcess proc >>= \case
diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs
index 4817fd6..3668a29 100644
--- a/Biz/Que/Host.hs
+++ b/Biz/Que/Host.hs
@@ -63,7 +63,7 @@ main = Exception.bracket startup shutdown <| uncurry Warp.run
putText <| "skey: " <> (show <| queSkey c)
return (quePort c, waiapp)
shutdown :: a -> IO a
- shutdown = pure . identity
+ shutdown = pure <. identity
newtype App a = App
{ runApp :: ReaderT (STM.TVar AppState) IO a
@@ -129,9 +129,9 @@ routes cfg = do
Scotty.get (Scotty.regex quepath) <| do
(ns, qp) <- extract
guardNs ns ["pub", "_"]
- app . modify <| upsertNamespace ns
+ app <. modify <| upsertNamespace ns
q <- app <| que ns qp
- poll <- Scotty.param "poll" !: (pure . const False)
+ poll <- Scotty.param "poll" !: (pure <. const False)
if poll
then Scotty.stream <| streamQue q
else do
@@ -151,7 +151,7 @@ routes cfg = do
>> Scotty.finish
guardNs ns ["pub", "_"]
-- passed all auth checks
- app . modify <| upsertNamespace ns
+ app <. modify <| upsertNamespace ns
q <- app <| que ns qp
qdata <- Scotty.body
_ <- liftIO <| Go.write q <| BSL.toStrict qdata
@@ -184,7 +184,7 @@ streamQue q write _ = loop q
where
loop c =
Go.read c
- >>= (write . Builder.byteStringInsert)
+ >>= (write <. Builder.byteStringInsert)
>> loop c
-- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist.
@@ -218,11 +218,11 @@ app = lift
-- | Get something from the app state
gets :: (AppState -> b) -> App b
-gets f = ask >>= liftIO . STM.readTVarIO >>= return </ f
+gets f = ask >>= liftIO <. STM.readTVarIO >>= return </ f
-- | Apply a function to the app state
modify :: (AppState -> AppState) -> App ()
-modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f
+modify f = ask >>= liftIO <. atomically <. flip STM.modifyTVar' f
-- | housing for a set of que paths
type Namespace = Text.Lazy.Text
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 09:36:24 +0000