summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.ghci4
-rw-r--r--Biz/Bild.hs141
-rw-r--r--Biz/Bild/Deps/Haskell.nix1
-rw-r--r--Biz/Bild/Rules.nix26
-rw-r--r--Biz/Bild/ShellHook.sh67
-rw-r--r--Biz/Cloud/Git.nix2
-rw-r--r--Biz/Dev/Configuration.nix2
-rw-r--r--Biz/Keys/Ben.key (renamed from Biz/Keys/Ben.pub)0
-rw-r--r--Biz/Keys/Deploy.key (renamed from Biz/Keys/Deploy.pub)0
-rw-r--r--Biz/Keys/Nick.key (renamed from Biz/Keys/Nick.pub)0
-rwxr-xr-xBiz/Lint.py8
-rw-r--r--Biz/Namespace.hs21
-rw-r--r--Biz/Users.nix8
-rw-r--r--Control/Concurrent/Sema.hs3
-rw-r--r--System/Random/Shuffle.hs7
15 files changed, 179 insertions, 111 deletions
diff --git a/.ghci b/.ghci
index 3f7039a..65154ef 100644
--- a/.ghci
+++ b/.ghci
@@ -1,6 +1,6 @@
:set -XOverloadedStrings
-:set prompt "λ "
-:set prompt-cont "| "
+:set prompt " λ "
+:set prompt-cont " | "
:set -Wall
:set -haddock
-- ':iq Module M' -> 'import qualified Module as M'
diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 23086a7..96f63ad 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -6,12 +6,9 @@
-- | A general purpose build tool.
--
--- Not all of the below design is implemented. Currently:
---
--- - with a nix build, results are linked in _/bild/nix/<target>
--- - with a dev build, results are stored in _/bild/dev/<target>
---
--- -----------------------------------------------------------------------------
+-- : out bild
+-- : dep docopt
+-- : dep regex-applicative
--
-- == Design constraints
--
@@ -119,7 +116,7 @@
module Biz.Bild where
import Alpha hiding (sym, (<.>))
-import Biz.Namespace (Namespace)
+import Biz.Namespace (Namespace (..))
import qualified Biz.Namespace as Namespace
import qualified Data.Char as Char
import qualified Data.List as List
@@ -137,8 +134,11 @@ main :: IO ()
main = Env.getArgs >>= Docopt.parseArgsOrExit help >>= run
where
run args =
- Docopt.getAllArgs args (Docopt.argument "target")
- |> mapM_ (\target -> analyze target >>= build)
+ mapM getNamespace (Docopt.getAllArgs args (Docopt.argument "target"))
+ /> catMaybes
+ /> filter isBuildableNs
+ >>= mapM analyze
+ >>= mapM_ build
help :: Docopt.Docopt
help =
@@ -156,7 +156,14 @@ type Dep = String
type Out = String
-data Compiler = Ghc | Ghcjs | Guile | NixBuild
+data Compiler
+ = GhcLib
+ | GhcExe
+ | GhcjsLib
+ | GhcjsExe
+ | Guile
+ | NixBuild
+ | Copy
deriving (Show)
data Target = Target
@@ -175,20 +182,42 @@ data Target = Target
}
deriving (Show)
-analyze :: String -> IO Target
-analyze s = do
- user <- Env.getEnv "USER"
+isBuildableNs :: Namespace -> Bool
+isBuildableNs (Namespace _ Namespace.Hs) = True
+isBuildableNs ns
+ | ns `elem` nixTargets = True
+ | otherwise = False
+
+nixTargets :: [Namespace]
+nixTargets =
+ [ Namespace ["Biz", "Pie"] Namespace.Nix,
+ Namespace ["Biz", "Que", "Prod"] Namespace.Nix,
+ Namespace ["Biz", "Cloud"] Namespace.Nix,
+ Namespace ["Biz", "Dev"] Namespace.Nix,
+ Namespace ["Hero", "Prod"] Namespace.Nix
+ ]
+
+getNamespace :: String -> IO (Maybe Namespace)
+getNamespace s = do
root <- Env.getEnv "BIZ_ROOT"
- host <- chomp </ readFile "/etc/hostname"
cwd <- Dir.getCurrentDirectory
- let path = cwd </> s
- let namespace@(Namespace.Namespace _ ext) =
- require "namespace" <| Namespace.fromPath root path
+ return <| Namespace.fromPath root <| cwd </> s
+
+analyze :: Namespace -> IO Target
+analyze namespace@(Namespace.Namespace _ ext) = do
+ user <- Env.getEnv "USER"
+ host <- chomp </ readFile "/etc/hostname"
+ let path = Namespace.toPath namespace
case ext of
Namespace.Hs -> do
content <- String.lines </ Prelude.readFile path
- let out = content /> Regex.match metaOut |> catMaybes |> head |> require "out"
- let compiler = if ".js" `List.isSuffixOf` out then Ghcjs else Ghc
+ let out =
+ content
+ /> Regex.match metaOut
+ |> catMaybes
+ |> head
+ |> fromMaybe mempty
+ let compiler = detectGhcCompiler out <| String.unlines content
return
Target
{ deps = content /> Regex.match metaDep |> catMaybes,
@@ -223,13 +252,41 @@ analyze s = do
builder = user <> "@localhost",
..
}
+ _ ->
+ return
+ Target
+ { deps = [],
+ compiler = Copy,
+ out = "",
+ builder = user <> "@localhost",
+ ..
+ }
+
+-- | Some rules for detecting the how to compile a ghc module. If there is an
+-- out, then we know it's some Exe; if the out ends in .js then it's GhcjsExe,
+-- otherwise GhcExe. That part is solved.
+--
+-- Detecting a Lib is harder, and much code can be compiled by both ghc and
+-- ghcjs. For now I'm just guarding against known ghcjs-only modules in the
+-- import list.
+detectGhcCompiler :: String -> String -> Compiler
+detectGhcCompiler out _ | jsSuffix out = GhcjsExe
+detectGhcCompiler out _ | not <| jsSuffix out || null out = GhcExe
+detectGhcCompiler _ content
+ | match "import GHCJS" = GhcjsLib
+ | otherwise = GhcLib
+ where
+ match s = s `List.isInfixOf` content
+
+jsSuffix :: String -> Bool
+jsSuffix = List.isSuffixOf ".js"
build :: Target -> IO ()
build target@Target {..} = do
root <- Env.getEnv "BIZ_ROOT"
case compiler of
- Ghc -> do
- putText <| "bild: dev: ghc: " <> Namespace.toPath namespace
+ GhcExe -> do
+ putStrLn <| "bild: dev: ghc-exe: " <> Namespace.toPath namespace
let outDir = root </> "_/bild/dev/bin"
Dir.createDirectoryIfMissing True outDir
putText <| "bild: dev: bilder: " <> Text.pack builder
@@ -248,8 +305,22 @@ build target@Target {..} = do
"-o",
outDir </> out
]
- Ghcjs -> do
- putText <| "bild: dev: ghcjs: " <> Namespace.toPath namespace
+ GhcLib -> do
+ putStrLn <| "bild: dev: ghc-lib: " <> Namespace.toPath namespace
+ putText <| "bild: dev: bilder: " <> Text.pack builder
+ Process.callProcess
+ "ghc"
+ [ "-Werror",
+ "-i" <> root,
+ "-odir",
+ root </> "_/bild/int",
+ "-hidir",
+ root </> "_/bild/int",
+ "--make",
+ path
+ ]
+ GhcjsExe -> do
+ putStrLn <| "bild: dev: ghcjs-exe: " <> Namespace.toPath namespace
let outDir = root </> "_/bild/dev/static"
Dir.createDirectoryIfMissing True outDir
putText <| "bild: dev: local: " <> Text.pack builder
@@ -268,13 +339,27 @@ build target@Target {..} = do
"-o",
outDir </> out
]
+ GhcjsLib -> do
+ putStrLn <| "bild: dev: ghcjs-lib: " <> Namespace.toPath namespace
+ putText <| "bild: dev: local: " <> Text.pack builder
+ Process.callProcess
+ "ghcjs"
+ [ "-Werror",
+ "-i" <> root,
+ "-odir",
+ root </> "_/bild/int",
+ "-hidir",
+ root </> "_/bild/int",
+ "--make",
+ path
+ ]
Guile -> do
- putText <| "bild: dev: guile: " <> Namespace.toPath namespace
+ putStrLn <| "bild: dev: guile: " <> Namespace.toPath namespace
putText <| "bild: dev: local: " <> Text.pack builder
putText "bild: guile TODO"
putText <| show target
NixBuild -> do
- putText <| "bild: nix: " <> Namespace.toPath namespace
+ putStrLn <| "bild: nix: " <> Namespace.toPath namespace
let outDir = root </> "_/bild/nix"
Dir.createDirectoryIfMissing True outDir
if null builder
@@ -284,7 +369,7 @@ build target@Target {..} = do
"nix-build"
[ path,
"-o",
- outDir </> (Text.unpack <| Namespace.toPath namespace),
+ outDir </> Namespace.toPath namespace,
-- Set default arguments to nix functions
"--arg",
"bild",
@@ -300,6 +385,10 @@ build target@Target {..} = do
"--builders",
builder
]
+ Copy -> do
+ putStrLn <| "bild: copy: " <> Namespace.toPath namespace
+ putText "bild: copy TODO"
+ putText <| show target
metaDep :: Regex.RE Char Dep
metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha)
diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix
index 001cdb2..dc33483 100644
--- a/Biz/Bild/Deps/Haskell.nix
+++ b/Biz/Bild/Deps/Haskell.nix
@@ -3,6 +3,7 @@ with hpkgs;
[
MonadRandom
QuickCheck
+ SafeSemaphore
acid-state
aeson
async
diff --git a/Biz/Bild/Rules.nix b/Biz/Bild/Rules.nix
index 9a7ad77..be9fa31 100644
--- a/Biz/Bild/Rules.nix
+++ b/Biz/Bild/Rules.nix
@@ -77,7 +77,7 @@ in rec {
ghcjs = main:
let
data = analyze main;
- ghcjs = mkGhcjsPackageSet (hp: selectAttrs data.dep hp);
+ ghcjs = mkGhcjsPackageSet (hp: selectAttrs data.deps hp);
in stdenv.mkDerivation {
name = data.module;
src = ../../.;
@@ -105,18 +105,18 @@ in rec {
# haskell deps
(mkGhcPackageSet haskellDeps)
# ghcjs doesn't need everything, and many things fail to build
- (mkGhcjsPackageSet [
- "aeson"
- "clay"
- "containers"
- "miso"
- "protolude"
- "servant"
- "split"
- "string-quote"
- "text"
- "ghcjs-base"
- ])
+ (mkGhcjsPackageSet (hp: with hp; [
+ aeson
+ clay
+ containers
+ miso
+ protolude
+ servant
+ split
+ string-quote
+ text
+ ghcjs-base
+ ]))
# scheme deps
nixpkgs.guile
diff --git a/Biz/Bild/ShellHook.sh b/Biz/Bild/ShellHook.sh
index e83973e..e307e04 100644
--- a/Biz/Bild/ShellHook.sh
+++ b/Biz/Bild/ShellHook.sh
@@ -7,7 +7,6 @@ function help() {
echo " deps manage dependencies with niv"
echo " ghci start ghci with correct options"
echo " help show this message"
- echo " hero compile and start a dev server for herocomics.app"
echo " lint auto-lint all changed files"
echo " pie product improvement engine"
echo " push send a namespace to the cloud"
@@ -34,28 +33,6 @@ function deps() {
alias ghci="ghci -i$BIZ_ROOT -ghci-script $BIZ_ROOT/.ghci"
-function hero() {
- export HERO_PORT=3000
- export HERO_KEEP=$BIZ_ROOT/_/keep
- export HERO_SKEY=$BIZ_ROOT/_/skey
- bild="runghc Biz.Bild"
- if [[ ! -z "${IN_NIX_SHELL}" ]]
- then
- out="_/bild/dev"
- # in dev mode, mmc.js is a directory of js assets
- export HERO_NODE=$BIZ_ROOT/$out/static/mmc.js
- rg --files \
- | entr -rcs \
- "$bild Hero.Host.hs && $bild Hero.Node.hs && $out/bin/mmc"
- else
- out="_/bild/nix"
- export HERO_NODE=$BIZ_ROOT/$out/Hero.Node/static
- rg --files \
- | entr -rcs \
- "$bild Hero.Host && $bild Hero.Node && $out/Hero.Host/bin/mmc"
- fi
-}
-
alias lint=$BIZ_ROOT/Biz/Lint.py
function pie() {
@@ -73,6 +50,7 @@ function push() {
else
target="$prefix.$1"
fi
+ echo "push: $target"
what=$(realpath "$BIZ_ROOT/_/bild/nix/$target")
# hack: get the domain from the activation script. there does not seem
# to be a way to get it from nix-instantiate
@@ -84,21 +62,18 @@ function push() {
# TODO: convert to haskell
function ship() {
- $BIZ_ROOT/Biz/Lint.py
- stuff=(${1})
+ lint
+ stuff=(${@})
if [[ ${#stuff[@]} -eq 0 ]]
then
stuff=(
- Biz.Cloud
- Biz.Dev
- Que.Prod
- Hero.Prod
+ Biz/Cloud.nix
+ Biz/Dev.nix
+ Biz/Que/Prod.nix
+ Hero/Prod.nix
)
fi
- for thing in ${stuff[@]}
- do
- bild $thing
- done
+ bild ${stuff[@]}
for thing in ${stuff[@]}
do
push $thing
@@ -106,27 +81,11 @@ function ship() {
}
# Poor man's ci
-function ci() {
- set -e
- lint **/*
- stuff=(
- Biz/Pie.hs
- Biz/Pie.nix
- Biz/Devalloc.hs
- Biz/Que/Site.hs
- Biz/Que/Host.hs
- Biz/Que/Prod.nix
- Biz/Cloud.nix
- Biz/Dev.nix
- Hero/Host.hs
- Hero/Node.hs
- Hero/Prod.nix
- )
- for thing in ${stuff[@]}
- do
- bild "$thing"
- done
- set +e
+function run-ci() {
+ lint **/* && bild **/*
}
+alias ci="time run-ci"
+
+export PS1='\n$(printf "%3.*s" $? $?)> '
help
diff --git a/Biz/Cloud/Git.nix b/Biz/Cloud/Git.nix
index 6104ced..82761ce 100644
--- a/Biz/Cloud/Git.nix
+++ b/Biz/Cloud/Git.nix
@@ -11,7 +11,7 @@
extraGitoliteRc = ''
$RC{SITE_INFO} = 'a computer is a bicycle for the mind.';
'';
- adminPubkey = builtins.readFile ../Keys/Ben.pub;
+ adminPubkey = builtins.readFile ../Keys/Ben.key;
};
};
}
diff --git a/Biz/Dev/Configuration.nix b/Biz/Dev/Configuration.nix
index 13be1be..0986131 100644
--- a/Biz/Dev/Configuration.nix
+++ b/Biz/Dev/Configuration.nix
@@ -247,7 +247,7 @@ in {
sshServe = {
enable = true;
keys = [
- (builtins.readFile ../Keys/Ben.pub)
+ (builtins.readFile ../Keys/Ben.key)
];
};
trustedUsers = [ "root" "ben" ];
diff --git a/Biz/Keys/Ben.pub b/Biz/Keys/Ben.key
index c661508..c661508 100644
--- a/Biz/Keys/Ben.pub
+++ b/Biz/Keys/Ben.key
diff --git a/Biz/Keys/Deploy.pub b/Biz/Keys/Deploy.key
index 664a2d9..664a2d9 100644
--- a/Biz/Keys/Deploy.pub
+++ b/Biz/Keys/Deploy.key
diff --git a/Biz/Keys/Nick.pub b/Biz/Keys/Nick.key
index 4dc08fb..4dc08fb 100644
--- a/Biz/Keys/Nick.pub
+++ b/Biz/Keys/Nick.key
diff --git a/Biz/Lint.py b/Biz/Lint.py
index fc035cb..c3e51df 100755
--- a/Biz/Lint.py
+++ b/Biz/Lint.py
@@ -89,12 +89,20 @@ if __name__ == "__main__":
else:
FILES = group_files(sys.argv[1:], [".hs", ".py"])
for hs in FILES[".hs"]:
+ if not os.path.exists(hs):
+ print("lint: does not exist:", hs)
+ continue
print(f"lint: {hs}")
run("ormolu", hs)
run("hlint", hs)
for py in FILES[".py"]:
+ if not os.path.exists(py):
+ print("lint: does not exist:", py)
+ continue
print(f"lint: {py}")
# Broken in our nixpkgs
# run("black", py)
run("pylint", py)
+ if ERRORS:
+ print("lint: errors:", ERRORS)
sys.exit(ERRORS)
diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs
index 48ae1e6..574a2fc 100644
--- a/Biz/Namespace.hs
+++ b/Biz/Namespace.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
+-- : dep regex-applicative
module Biz.Namespace
( Namespace (..),
Ext (..),
@@ -14,26 +15,31 @@ where
import Alpha
import qualified Data.Char as Char
import qualified Data.List as List
-import qualified Data.Text as Text
import qualified Text.Regex.Applicative as Regex
-data Ext = Hs | Scm | Nix
- deriving (Show)
+data Ext = Hs | Scm | Nix | Md | Css | Py | Sh | Key | Json | None
+ deriving (Eq, Show)
data Namespace = Namespace [String] Ext
- deriving (Show)
+ deriving (Eq, Show)
match :: String -> Maybe Namespace
match = Regex.match <| Namespace </ path <* Regex.sym '.' <*> ext
where
name =
Regex.many (Regex.psym Char.isUpper)
- <> Regex.many (Regex.psym Char.isLower)
+ <> Regex.many (Regex.psym Char.isAlphaNum)
path = Regex.many (name <* Regex.string "/" <|> name)
ext =
Nix <$ Regex.string "nix"
<|> Hs <$ Regex.string "hs"
<|> Scm <$ Regex.string "scm"
+ <|> Md <$ Regex.string "md"
+ <|> Css <$ Regex.string "css"
+ <|> Py <$ Regex.string "py"
+ <|> Sh <$ Regex.string "sh"
+ <|> Key <$ Regex.string "key"
+ <|> Json <$ Regex.string "json"
fromPath :: String -> String -> Maybe Namespace
fromPath bizRoot absPath =
@@ -46,9 +52,8 @@ toHaskellModule (Namespace parts Hs) = joinWith "." parts
toHaskellModule (Namespace _ ext) =
panic <| "can't convert " <> show ext <> " to a Haskell module"
-toPath :: Namespace -> Text
+toPath :: Namespace -> FilePath
toPath (Namespace parts ext) =
- Text.pack
- <| joinWith "/" parts
+ joinWith "/" parts
<> "."
<> lowercase (show ext)
diff --git a/Biz/Users.nix b/Biz/Users.nix
index 8a804ca..0f68b50 100644
--- a/Biz/Users.nix
+++ b/Biz/Users.nix
@@ -14,20 +14,20 @@
deploy = {
isNormalUser = true;
home = "/home/deploy";
- openssh.authorizedKeys.keyFiles = [ ./Keys/Deploy.pub ];
+ openssh.authorizedKeys.keyFiles = [ ./Keys/Deploy.key ];
extraGroups = [ "wheel" ];
};
#
# humans
#
- root.openssh.authorizedKeys.keyFiles = [ ./Keys/Ben.pub ];
+ root.openssh.authorizedKeys.keyFiles = [ ./Keys/Ben.key ];
root.password = "erewhon";
ben = {
description = "Ben Sima";
isNormalUser = true;
home = "/home/ben";
- openssh.authorizedKeys.keyFiles = [ ./Keys/Ben.pub ];
+ openssh.authorizedKeys.keyFiles = [ ./Keys/Ben.key ];
extraGroups = [ "wheel" "docker" ];
hashedPassword =
"$6$SGhdoRB6DhWe$elW8RQE1ebe8JKf1ALW8jGZTPCyn2rpq/0J8MV/A9y8qFMEhA.Z2eiexMgptohZAK5kcGOc6HIUgNzJqnDUvY.";
@@ -36,7 +36,7 @@
description = "Nick Sima";
isNormalUser = true;
home = "/home/nick";
- openssh.authorizedKeys.keyFiles = [ ./Keys/Nick.pub ];
+ openssh.authorizedKeys.keyFiles = [ ./Keys/Nick.key ];
extraGroups = [ "docker" ];
};
};
diff --git a/Control/Concurrent/Sema.hs b/Control/Concurrent/Sema.hs
index c105cf8..202aa65 100644
--- a/Control/Concurrent/Sema.hs
+++ b/Control/Concurrent/Sema.hs
@@ -1,8 +1,11 @@
+-- : dep SafeSemaphore
module Control.Concurrent.Sema
( mapPool,
)
where
+import Alpha
+import Control.Concurrent.Async (mapConcurrently)
import qualified Control.Concurrent.MSem as Sem
-- | Simaphore-based throttled 'mapConcurrently'.
diff --git a/System/Random/Shuffle.hs b/System/Random/Shuffle.hs
index d26361f..435f083 100644
--- a/System/Random/Shuffle.hs
+++ b/System/Random/Shuffle.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
-- |
@@ -24,6 +26,7 @@ module System.Random.Shuffle
)
where
+import Alpha
import Control.Monad
( liftM2,
)
@@ -70,7 +73,7 @@ shuffle elements = shuffleTree (buildTree elements)
shuffleTree (Leaf e) [] = [e]
shuffleTree tree (r : rs) =
let (b, rest) = extractTree r tree in b : shuffleTree rest rs
- shuffleTree _ _ = error "[shuffle] called with lists of different lengths"
+ shuffleTree _ _ = panic "[shuffle] called with lists of different lengths"
-- Extracts the n-th element from the tree and returns
-- that element, paired with a tree with the element
-- deleted.
@@ -86,7 +89,7 @@ shuffle elements = shuffleTree (buildTree elements)
let (e, l') = extractTree n l in (e, Node (c - 1) l' r)
| otherwise =
let (e, r') = extractTree (n - cl) r in (e, Node (c - 1) l r')
- extractTree _ _ = error "[extractTree] impossible"
+ extractTree _ _ = panic "[extractTree] impossible"
-- | Given a sequence (e1,...en) to shuffle, its length, and a random
-- generator, compute the corresponding permutation of the input
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 06:20:41 +0000