summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Alpha.hs12
-rw-r--r--Biz/Bild/Deps.nix1
-rw-r--r--Biz/Bild/Rules.nix7
-rw-r--r--Biz/Pie.hs6
-rw-r--r--Control/Concurrent/Go.hs2
-rw-r--r--Que/Server.hs35
-rw-r--r--Que/Website.hs14
7 files changed, 36 insertions, 41 deletions
diff --git a/Alpha.hs b/Alpha.hs
index 934cc31..e19f9be 100644
--- a/Alpha.hs
+++ b/Alpha.hs
@@ -46,13 +46,11 @@ module Alpha
)
where
-import Data.Function ((&))
-import Data.Functor ((<&>))
import Data.String
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
-import Protolude as X
+import Protolude as X hiding (($), (&))
-- | Debugging printf
say :: Text -> IO ()
@@ -60,7 +58,7 @@ say = putText
-- | Alias for map, fmap, <$>
(</) :: Functor f => (a -> b) -> f a -> f b
-(</) = fmap
+f </ g = fmap f g
-- | Double fmap. A function on the left goes "into" two functors
-- (i.e. it goes "two levels deep"), applies the function to the inner
@@ -71,20 +69,20 @@ say = putText
-- | Normal function application. Do the right side, then pass the
-- return value to the function on the left side.
(<|) :: (a -> b) -> a -> b
-(<|) = ($)
+f <| g = f (g)
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
-(|>) = (&)
+f |> g = g (f)
-- | 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
-(/>) = (<&>)
+f /> g = fmap g f
-- | Removes newlines from text.
chomp :: Text -> Text
diff --git a/Biz/Bild/Deps.nix b/Biz/Bild/Deps.nix
index dccbd81..a1e72ba 100644
--- a/Biz/Bild/Deps.nix
+++ b/Biz/Bild/Deps.nix
@@ -7,6 +7,7 @@
"bytestring"
"capability"
"clay"
+ "cmark"
"config-ini"
"containers"
"directory"
diff --git a/Biz/Bild/Rules.nix b/Biz/Bild/Rules.nix
index 6afe9a0..9fea5df 100644
--- a/Biz/Bild/Rules.nix
+++ b/Biz/Bild/Rules.nix
@@ -36,6 +36,10 @@ let
deps = lib.lists.flatten (removeNull
(map (builtins.match "^-- : dep ([[:alnum:]._-]*)$")
(lines content)));
+
+ sysdeps = lib.lists.flatten (removeNull
+ (map (builtins.match "^-- : sys ([[:alum:]._-]*)$")
+ (lines content)));
};
mkGhc = compiler: (deps: compiler (hp:
@@ -56,7 +60,7 @@ in {
in stdenv.mkDerivation {
name = data.module;
src = ../.;
- nativeBuildInputs = [ ghc ];
+ nativeBuildInputs = [ ghc ] ++ depsToPackageSet nixpkgs data.sysdeps;
strictDeps = true;
buildPhase = ''
mkdir -p $out/bin
@@ -111,6 +115,7 @@ in {
"ghcjs-base"
])
+ nixpkgs.cmark
nixpkgs.figlet
nixpkgs.hlint
nixpkgs.lolcat
diff --git a/Biz/Pie.hs b/Biz/Pie.hs
index 3823db3..7e1c19e 100644
--- a/Biz/Pie.hs
+++ b/Biz/Pie.hs
@@ -97,7 +97,7 @@ loadForm :: Namespace -> IO Form
loadForm ns = Directory.doesFileExist file >>= \case
False -> touch file >> return mempty
True -> Aeson.decodeFileStrict file >>= \case
- Nothing -> panic $ Text.pack $ "could not decode: " ++ file
+ Nothing -> panic <| Text.pack <| "could not decode: " ++ file
Just x -> return x
where
file = formFile ns
@@ -123,7 +123,7 @@ move mov form = case mov of
Exit.ExitFailure _ ->
Process.callProcess "git" ["switch", "-c", branch]
>> return form
- Update -> Haskeline.runInputT Haskeline.defaultSettings $ do
+ Update -> Haskeline.runInputT Haskeline.defaultSettings <| do
timestamp <- liftIO Clock.getCurrentTime
onTrack <- parseBool </ question "Are you on track?"
isLaunched <- parseBool </ question "Are you launched?"
@@ -135,7 +135,7 @@ move mov form = case mov of
biggestObstacle <- parseText </ question "What is your biggest obstacle?"
goals <- parseText </ question "What are your top 1-3 goals for next week?"
return <| form {roll = BuildSprint {..} : (roll form)}
- Feedback -> Haskeline.runInputT Haskeline.defaultSettings $ do
+ Feedback -> Haskeline.runInputT Haskeline.defaultSettings <| do
timestamp <- liftIO Clock.getCurrentTime
user <- parseText </ question "User?"
howDisappointed <- parseDisappointment </ question "How disappointed? (1=very, 2=somewhat, 3=not)"
diff --git a/Control/Concurrent/Go.hs b/Control/Concurrent/Go.hs
index 08a1d65..69d35b8 100644
--- a/Control/Concurrent/Go.hs
+++ b/Control/Concurrent/Go.hs
@@ -50,7 +50,7 @@ fork = Concurrent.forkIO
chan :: Int -> IO (Channel a)
chan n = do
(i, o) <- Chan.newChan n
- return $ Channel i o n
+ return <| Channel i o n
-- | A channel for broadcasting to multiple consumers. See 'mult'.
type Mult a = Chan.OutChan a
diff --git a/Que/Server.hs b/Que/Server.hs
index 4cb0b32..9217ee8 100644
--- a/Que/Server.hs
+++ b/Que/Server.hs
@@ -25,13 +25,7 @@ module Que.Server
)
where
-import Alpha hiding
- ( Text,
- get,
- gets,
- modify,
- poll,
- )
+import Alpha hiding (gets, modify, poll)
import qualified Control.Concurrent.Go as Go
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Exception
@@ -41,11 +35,8 @@ import qualified Data.ByteString.Lazy as BSL
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.Text.Encoding as Encoding
-import Data.Text.Lazy
- ( Text,
- fromStrict,
- )
-import qualified Data.Text.Lazy.IO as Text
+import qualified Data.Text.Lazy as Text.Lazy
+import qualified Data.Text.Lazy.IO as Text.Lazy.IO
import qualified Network.HTTP.Types.Status as Http
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
@@ -105,7 +96,7 @@ instance Envy.DefConfig Config where
instance Envy.FromEnv Config
-routes :: Scotty.ScottyT Text App ()
+routes :: Scotty.ScottyT Text.Lazy.Text App ()
routes = do
Scotty.middleware logStdout
let quepath = "^\\/([[:alnum:]_-]+)\\/([[:alnum:]._/-]*)$"
@@ -117,7 +108,7 @@ routes = do
-- GET /_/dash
Scotty.get (Scotty.literal "/_/dash") <| do
authkey <- fromMaybe "" </ Scotty.header "Authorization"
- adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin"
+ adminkey <- liftIO <| lchomp </ Text.Lazy.IO.readFile "/run/keys/que-admin"
if authkey == adminkey
then do
d <- app <| gets ques
@@ -141,7 +132,7 @@ routes = do
q <- app <| que ns qp
poll <- Scotty.param "poll" !: (pure . const False)
if poll
- then Scotty.stream $ streamQue q
+ then Scotty.stream <| streamQue q
else do
r <- liftIO <| Go.read q
Scotty.html <| fromStrict <| Encoding.decodeUtf8 r
@@ -150,7 +141,7 @@ routes = do
-- Put a value on a que. Returns immediately.
Scotty.post (Scotty.regex quepath) <| do
authkey <- fromMaybe "" </ Scotty.header "Authorization"
- adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin"
+ adminkey <- liftIO <| lchomp </ Text.Lazy.IO.readFile "/run/keys/que-admin"
(ns, qp) <- extract
-- Only allow my IP or localhost to publish to '_' namespace
when ("_" == ns && authkey /= adminkey)
@@ -167,7 +158,7 @@ routes = do
-- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist`
-- list, return a 405 error.
-guardNs :: Text -> [Text] -> Scotty.ActionT Text App ()
+guardNs :: Text.Lazy.Text -> [Text.Lazy.Text] -> Scotty.ActionT Text.Lazy.Text App ()
guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do
Scotty.status Http.methodNotAllowed405
Scotty.text
@@ -179,10 +170,10 @@ guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do
-- | recover from a scotty-thrown exception.
(!:) ::
-- | action that might throw
- Scotty.ActionT Text App a ->
+ Scotty.ActionT Text.Lazy.Text App a ->
-- | a function providing a default response instead
- (Text -> Scotty.ActionT Text App a) ->
- Scotty.ActionT Text App a
+ (Text.Lazy.Text -> Scotty.ActionT Text.Lazy.Text App a) ->
+ Scotty.ActionT Text.Lazy.Text App a
(!:) = Scotty.rescue
-- | Forever write the data from 'Que' to 'Wai.StreamingBody'.
@@ -212,7 +203,7 @@ insertQue ns qp q as = as {ques = newQues}
newQues = HashMap.insert ns newQbase (ques as)
newQbase = HashMap.insert qp q <| grab ns <| ques as
-extract :: Scotty.ActionT Text App (Namespace, Quepath)
+extract :: Scotty.ActionT Text.Lazy.Text App (Namespace, Quepath)
extract = do
ns <- Scotty.param "1"
path <- Scotty.param "2"
@@ -232,7 +223,7 @@ modify :: (AppState -> AppState) -> App ()
modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f
-- | housing for a set of que paths
-type Namespace = Text
+type Namespace = Text.Lazy.Text
-- | a que is just a channel of bytes
type Que = Go.Channel Message
diff --git a/Que/Website.hs b/Que/Website.hs
index 7eb3ae6..623173b 100644
--- a/Que/Website.hs
+++ b/Que/Website.hs
@@ -38,8 +38,8 @@ main = do
[src, ns] -> return (src, Text.pack ns)
_ -> Exit.die "usage: que-website <srcdir> [namespace]"
mKey <- getKey ns
- putText $ "serving " <> Text.pack src <> " at " <> ns
- run mKey ns $
+ putText <| "serving " <> Text.pack src <> " at " <> ns
+ run mKey ns <|
Sources
{ index = src </> "index.md",
client = src </> "client.py",
@@ -98,7 +98,7 @@ run key ns Sources {..} = Async.runConcurrently actions |> void
toHtml :: FilePath -> IO ByteString
toHtml md =
BS.pack
- <$> Process.readProcess
+ </ Process.readProcess
"pandoc"
[ "--include-in-header",
style,
@@ -112,7 +112,7 @@ run key ns Sources {..} = Async.runConcurrently actions |> void
[]
serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO ()
-serve Nothing "pub" path content = runReq defaultHttpConfig $ do
+serve Nothing "pub" path content = runReq defaultHttpConfig <| do
_ <-
req
POST
@@ -120,9 +120,9 @@ serve Nothing "pub" path content = runReq defaultHttpConfig $ do
(ReqBodyBs content)
ignoreResponse
mempty
- liftIO $ return ()
+ liftIO <| return ()
serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p
-serve (Just key) ns path content = runReq defaultHttpConfig $ do
+serve (Just key) ns path content = runReq defaultHttpConfig <| do
let options =
header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound
_ <-
@@ -132,4 +132,4 @@ serve (Just key) ns path content = runReq defaultHttpConfig $ do
(ReqBodyBs content)
ignoreResponse
options
- liftIO $ return ()
+ liftIO <| return ()
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 06:41:39 +0000