propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

commit f2fdc40ae4f6cab012b5f848b744a69589f0a1d3
parent df8253c382721ae4ec1b264ae3b19d920f9b4902
Author: rsiddharth <s@ricketyspace.net>
Date:   Fri,  5 Jul 2019 17:28:34 -0400

Merge tag '5.9.0'

tagging package propellor version 5.9.0

Diffstat:
debian/changelog | 29+++++++++++++++++++++++++++++
doc/forum/WIP_adding_dhcp_records_to_libvirt.mdwn | 31+++++++++++++++++++++++++++++++
doc/forum/WIP_adding_dhcp_records_to_libvirt/comment_1_9feaf88f735f6571835502cc9e15524b._comment | 12++++++++++++
doc/forum/commands_that_need_files.mdwn | 9+++++++++
doc/forum/commands_that_need_files/comment_1_4ffacadef38a131fa7e22204f9c4f882._comment | 8++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo.mdwn | 21+++++++++++++++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_1_e522e00ee4d4b072d80faef748450a52._comment | 10++++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_2_3dcd6f95340abed0accfecda716fd1f6._comment | 16++++++++++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_3_a273b2f5a904e7b16576a750538296dc._comment | 8++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_4_26738f91fe511b49552a68e70f201059._comment | 49+++++++++++++++++++++++++++++++++++++++++++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_5_05439bebb8c0dee0850fb2ffe3e117c3._comment | 8++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_6_c7f1e82b71c3317a25230e076eb0a330._comment | 9+++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_7_de411d55ffbd72c5a4182168dead6b29._comment | 46++++++++++++++++++++++++++++++++++++++++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_8_ba9fabe0096cd8808c4a50ea3ebe543c._comment | 10++++++++++
doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_9_49c03760f833632a50b88be792395a5f._comment | 25+++++++++++++++++++++++++
doc/news/version_5.4.1.mdwn | 15---------------
doc/news/version_5.8.0.mdwn | 19+++++++++++++++++++
doc/todo/dhcp_support_for_Propellor.Property.Libvirt.mdwn | 14++++++++++++++
doc/todo/use_ghc_8.0_custom_compile_errors.mdwn | 27++++++++++++++++-----------
doc/todo/virtio-fs_image_type_for_Propellor.Property.Libvirt.mdwn | 3+++
joeyconfig.hs | 8+++++---
propellor.cabal | 10+++++++---
src/Propellor/EnsureProperty.hs | 43++++++++++++++++++++++++++++++++++---------
src/Propellor/PropAccum.hs | 17++++++++++++++---
src/Propellor/Property/Aiccu.hs | 5++---
src/Propellor/Property/Atomic.hs | 12++++--------
src/Propellor/Property/Libvirt.hs | 2+-
src/Propellor/Property/SiteSpecific/JoeySites.hs | 13+++++++++----
src/Propellor/Property/Systemd.hs | 1+
src/Propellor/Property/Tor.hs | 30++++++++++++++++--------------
src/Propellor/Types.hs | 38++++++++++++++++++++++++++++++--------
src/Propellor/Types/MetaTypes.hs | 158+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------
stack.yaml | 3+++
33 files changed, 591 insertions(+), 118 deletions(-)

diff --git a/debian/changelog b/debian/changelog @@ -1,3 +1,32 @@ +propellor (5.9.0) unstable; urgency=medium + + * Added custom type error messages when Properties don't combine due to + conflicting MetaTypes. + * Added custom type error messages for ensureProperty and tightenTargets. + * Note that those changes made ghc 8.0.1 in a few cases unable to infer + types when ensureProperty or tightenTargets is used, while later ghc + versions had no difficulty. If this affects building your properties, + adding a type annotation to the code will work around the problem. + * Added custom type error messages displayed when type inference + fails when using ensureProperty and tightenTargets, that suggest + adding a type annotation. + * Use the type-errors library to detect when the type checker gets stuck + unable to reduce type-level operations on MetaTypes, and avoid + displaying massive error messages. + * But, since type-errors is a new library not available in eg Debian + yet, added a WithTypeErrors build flag. When the library is not + available, cabal will automatically disable that build flag, + and it will build without the type-errors library. + * EnsurePropertyAllowed, TightenTargetsAllowed, and CheckCombinable + types have changed to Constraint. + (API change) + * Try harder to avoid displaying an excessive amount of type error + messages when many properties have been combined in a props list. + * Libvirt.installed: install libvirt-daemon-system + Thanks, David Bremner + + -- Joey Hess <id@joeyh.name> Tue, 02 Jul 2019 16:27:07 -0400 + propellor (5.8.0) unstable; urgency=medium * Fix bug in File.containsShellSetting that replaced whole shell conffile diff --git a/doc/forum/WIP_adding_dhcp_records_to_libvirt.mdwn b/doc/forum/WIP_adding_dhcp_records_to_libvirt.mdwn @@ -0,0 +1,31 @@ +I'm working on adding static (predictable) dhcp records to libvirt guests (code at the end). It seems like I might need to either do the equivalent of +[[!format bash """ +virsh net-update default delete ip-dhcp-host "<host mac='52:54:00:f0:62:01'/>" --config --live || /bin/true +virsh net-update default add ip-dhcp-host "<host mac='52:54:00:f0:62:01' ip='192.168.122.32'/>" --config --live +"""]] +or parse the xml output of "virsh net-dumpxml". Is there some simple lightweight xml parsing option? Last time I tried something like this was a decade ago using HXT.Arrow, which didn't really end well. + +[[!format haskell """ +staticDHCP :: Host -> IPAddr -> Maybe Network.Gateway -> Property UnixLike +staticDHCP h ip gw = property "assign ip to host via dhcp" $ do + mac <- liftIO $ macAddress + case mac of + Nothing -> errorMessage "no interface" + Just addr -> makeChange $ unlessM (updateIt addr) $ + errorMessage "failed to update network" + where + updateIt mac = boolSystem "virsh" [ Param "net-update" + , Param "default" + , Param "add-last" + , Param "ip-dhcp-host" + , Param $ "<host mac=\""++mac++"\" ip=\""++(ifaceToString ip)++"\"/>" + , Param "--config" + , Param "--live"] + ifaceToString (IPv6 ipstr) = ipstr + ifaceToString (IPv4 ipstr) = ipstr + macAddress = do + ifaces <- virshGetColumns ["domiflist", hostName h] + case ifaces of + [] -> return Nothing + (i:_) -> return $ Just $ Propellor.Base.last i +"""]] diff --git a/doc/forum/WIP_adding_dhcp_records_to_libvirt/comment_1_9feaf88f735f6571835502cc9e15524b._comment b/doc/forum/WIP_adding_dhcp_records_to_libvirt/comment_1_9feaf88f735f6571835502cc9e15524b._comment @@ -0,0 +1,12 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 1""" + date="2019-06-15T16:35:46Z" + content=""" +The former seems easier than parsing the XML. + +I mean, aeson is quite good and easy to parse XML with, +but I prefer to keep propellor's haskell dependencies minimal +and so if you used aeson there would be a big question about merging the +result into propellor core. +"""]] diff --git a/doc/forum/commands_that_need_files.mdwn b/doc/forum/commands_that_need_files.mdwn @@ -0,0 +1,9 @@ +I want to run "virsh update-device guest-name snippet.xml", for the moment from Cmd.cmdProperty. snippet.xml should contain the actual configuration information. I'm wondering what the best approach is. + +1. create a persistent copy of this file using File.hasContent or similar +2. generate a temporary file when running the property. +3. Use a file from the propellor repo + +(1) is slightly gross because the persistent copy is used only when running propellor. +(2) I don't really know how to do in propellor; I guess it has to do with monads. +(3) I don't know if this will work or is frowned upon for some reason. diff --git a/doc/forum/commands_that_need_files/comment_1_4ffacadef38a131fa7e22204f9c4f882._comment b/doc/forum/commands_that_need_files/comment_1_4ffacadef38a131fa7e22204f9c4f882._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="spwhitton" + avatar="http://cdn.libravatar.org/avatar/9c3f08f80e67733fd506c353239569eb" + subject="comment 1" + date="2019-06-02T00:35:19Z" + content=""" +I would use (2). Look for the string `withTmpFile` in Libvirt.hs to see how it's done. +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo.mdwn b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo.mdwn @@ -0,0 +1,21 @@ +When there were upstream changes available, propellor used to prompt me to +merge upstream changes into my local propellor repo with: + + git merge upstream/master + +Of late, propellor has not been prompting me to merge upstream changes and +my local propellor repo is stuck at ~version 5.3.5 + +Is there is (another manual) way to merge upstream changes into my local propellor +repo? + +My propellor repo is at + + git clone git://git.ricketyspace.net/propellor.git + +Note that I've have some minor updates under the `src/` directory. [Some][0] [of][1] [them][2] were +merged into upstream. + +[0]: https://propellor.branchable.com/forum/DNS_-_Support_for_Multiline_TXT_records/ +[1]: https://propellor.branchable.com/forum/Make_clean_fails_in_openbsd/ +[2]: https://propellor.branchable.com/forum/__96__Propellor.Bootstrap.cabalBuild__96___fails_in_openbsd/ diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_1_e522e00ee4d4b072d80faef748450a52._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_1_e522e00ee4d4b072d80faef748450a52._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="spwhitton" + avatar="http://cdn.libravatar.org/avatar/9c3f08f80e67733fd506c353239569eb" + subject="comment 1" + date="2019-06-02T00:34:48Z" + content=""" +The `upstream/master` thing is probably propellor's code looking in `/usr/src/propellor` for a new upstream version. + +Do you perhaps no longer have the Debian package of propellor installed? +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_2_3dcd6f95340abed0accfecda716fd1f6._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_2_3dcd6f95340abed0accfecda716fd1f6._comment @@ -0,0 +1,16 @@ +[[!comment format=mdwn + username="s@aa9ff9ce06b08acfd2a93ebd342ce6879430fbdd" + nickname="s" + avatar="http://cdn.libravatar.org/avatar/81bf27f8b35011d1846711fa37a5588f" + subject="comment 2" + date="2019-06-02T01:10:43Z" + content=""" +[@spwhitton](https://propellor.branchable.com/user/spwhitton/), My current host machine is OpenBSD. So, I get propellor from `cabal`. + +Currently I've propellor 5.8.0 installed from cabal. + +My local propellor repo is itself is stuck at 5.3.5 (<https://git.ricketyspace.net/propellor/files.html>). + +I wanted to know if there was a way to manually merge upstream changes into my local propellor repo? + +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_3_a273b2f5a904e7b16576a750538296dc._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_3_a273b2f5a904e7b16576a750538296dc._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="spwhitton" + avatar="http://cdn.libravatar.org/avatar/9c3f08f80e67733fd506c353239569eb" + subject="comment 3" + date="2019-06-03T03:43:33Z" + content=""" +You can always just fetch and merge upstream's release tags. +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_4_26738f91fe511b49552a68e70f201059._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_4_26738f91fe511b49552a68e70f201059._comment @@ -0,0 +1,49 @@ +[[!comment format=mdwn + username="s@aa9ff9ce06b08acfd2a93ebd342ce6879430fbdd" + nickname="s" + avatar="http://cdn.libravatar.org/avatar/81bf27f8b35011d1846711fa37a5588f" + subject="comment 4" + date="2019-06-04T00:38:58Z" + content=""" +[@spwhitton](spwhittonhttps://propellor.branchable.com/user/spwhitton/), Sorry I should've mentioned it before. I've already tried merging upstream changes using `git merge`, I'm unable to merge it due to different commit histories: + +``` +cygnus$ git remote -v +s g@git.rs:~/c/propellor.git (fetch) +s g@git.rs:~/c/propellor.git (push) +u git://propellor.branchable.com/propellor (fetch) +u git://propellor.branchable.com/propellor (push) + + +cygnus$ git tag -l | grep 5.8.0 +5.8.0 + +cygnus$ git merge 5.8.0 +fatal: refusing to merge unrelated histories +cygnus$ git merge u/master +fatal: refusing to merge unrelated histories +``` + +First commit in upstream repo: + +``` +cygnus$ git log --reverse u/master | head -n 5 +commit d9af8bac5eb7836a3c90e37e870fd73d30b841fd +Author: Joey Hess <joey@kitenet.net> +Date: Sat Mar 29 23:10:52 2014 -0400 + + initial check-in +``` + +First commit in my repo: + +``` +cygnus$ git log --reverse s/master | head -n 5 +commit ff6173d6cd45e383da0f315bc80b52d486306cbc +Author: build <build@buildhost> +Date: Tue Nov 22 14:16:29 2016 -0700 + + distributed version of propellor + +``` +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_5_05439bebb8c0dee0850fb2ffe3e117c3._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_5_05439bebb8c0dee0850fb2ffe3e117c3._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="spwhitton" + avatar="http://cdn.libravatar.org/avatar/9c3f08f80e67733fd506c353239569eb" + subject="comment 5" + date="2019-06-05T15:08:02Z" + content=""" +You can pass `-X theirs --allow-unrelated-histories` or similar. +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_6_c7f1e82b71c3317a25230e076eb0a330._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_6_c7f1e82b71c3317a25230e076eb0a330._comment @@ -0,0 +1,9 @@ +[[!comment format=mdwn + username="s@aa9ff9ce06b08acfd2a93ebd342ce6879430fbdd" + nickname="s" + avatar="http://cdn.libravatar.org/avatar/81bf27f8b35011d1846711fa37a5588f" + subject="comment 6" + date="2019-06-06T03:00:43Z" + content=""" +[@spwhitton](https://propellor.branchable.com/user/spwhitton/), Thank you very much. That worked! +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_7_de411d55ffbd72c5a4182168dead6b29._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_7_de411d55ffbd72c5a4182168dead6b29._comment @@ -0,0 +1,46 @@ +[[!comment format=mdwn + username="s@aa9ff9ce06b08acfd2a93ebd342ce6879430fbdd" + nickname="s" + avatar="http://cdn.libravatar.org/avatar/81bf27f8b35011d1846711fa37a5588f" + subject="comment 7" + date="2019-06-06T03:13:02Z" + content=""" +Documenting it (in case there is another user who wishes to do the same): + +Add upstream repo and fetch tags: + +``` +$ cd ~/.propellor + +$ git remote add u git://propellor.branchable.com/propellor +$ git fetch u --tags +``` + +Look for the list releases: + +``` +$ git tag -l +0.1 +0.1.1 +0.1.2 +0.2.0 +0.2.1 +... +... +... +X.Y.Z +``` + +To merge release `X.Y.Z` into your master branch, do: + +``` +$ git merge -X theirs --allow-unrelated-histories X.Y.Z +``` + +Fix any conflicts and: + +``` +$ git commit +``` + +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_8_ba9fabe0096cd8808c4a50ea3ebe543c._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_8_ba9fabe0096cd8808c4a50ea3ebe543c._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="spwhitton" + avatar="http://cdn.libravatar.org/avatar/9c3f08f80e67733fd506c353239569eb" + subject="comment 8" + date="2019-06-08T20:21:57Z" + content=""" +The `git://` protocol is unencrypted and unauthenticated and you're not verifying Joey's PGP signature on the tag that you merge, so this approach is dangerous. + +I would insert a `git verify-tag` step in there. You'd want to make a record of (and perhaps locally sign) Joey's PGP key. +"""]] diff --git a/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_9_49c03760f833632a50b88be792395a5f._comment b/doc/forum/merging_upstream_changes_into_my_local_propellor_repo/comment_9_49c03760f833632a50b88be792395a5f._comment @@ -0,0 +1,25 @@ +[[!comment format=mdwn + username="s@aa9ff9ce06b08acfd2a93ebd342ce6879430fbdd" + nickname="s" + avatar="http://cdn.libravatar.org/avatar/81bf27f8b35011d1846711fa37a5588f" + subject="comment 9" + date="2019-06-15T16:04:22Z" + content=""" +Thanks again [@spwhitton](https://propellor.branchable.com/user/spwhitton/). I've verified the tag with Joey's GPG keys. + +Documenting here: + +Get Joey's [GPG keys](https://joeyh.name/contact/) + +``` +gpg2 --recv-keys 'E85A 5F63 B31D 24C1 EBF0 D81C C910 D922 2512 E3C7' +``` + +Verify the release tag before merging it into your local repo: + +``` +cd ~/.propellor +git verify-tag X.Y.Z +``` + +"""]] diff --git a/doc/news/version_5.4.1.mdwn b/doc/news/version_5.4.1.mdwn @@ -1,14 +0,0 @@ -propellor 5.4.1 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Modernized and simplified the MetaTypes implementation now that - compatability with ghc 7 is no longer needed. - * Use git verify-commit to verify gpg signatures, rather than the old - method of parsing git log output. Needs git 2.0. - * Added ConfFile.containsShellSetting, ConfFile.lacksShellSetting, - and EtcDefault.set properties. Thanks, Sean Whitton - * Dns: Support TXT values longer than bind's maximum string length - of 255 bytes. Thanks, rsiddharth. - * Docker and HostingProvider.CloudAtCost modules are not being - maintained, so marked them as such. - Seeking a maintainer for the Docker module; I anticipate - removing the CloudAtCost module in the next API bump."""]]- \ No newline at end of file diff --git a/doc/news/version_5.8.0.mdwn b/doc/news/version_5.8.0.mdwn @@ -0,0 +1,18 @@ +propellor 5.8.0 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Fix bug in File.containsShellSetting that replaced whole shell conffile + content with the setting if the file did not previously contain a line + setting the key to some value. + * Removed inChroot, instead use hasContainerCapability FilesystemContained. + (API change) + * Hostname: Properties that used to not do anything in a systemd or + docker container will now change the container's hostname, + since it's namespaced. + * Add User.ownsWithPrimaryGroup + Thanks, Sean Whitton + * Ssh.userKeys, Ssh.userKeyAt: Create .ssh directory when it does not yet + exist. + * Ssh.userKeyAt: When a relative filepath is provided, it's put inside + the user's .ssh directory. + * Fix Git.pulled always reporting a change. + Thanks, Sean Whitton"""]]+ \ No newline at end of file diff --git a/doc/todo/dhcp_support_for_Propellor.Property.Libvirt.mdwn b/doc/todo/dhcp_support_for_Propellor.Property.Libvirt.mdwn @@ -0,0 +1,14 @@ +I'd like a convenient way to add dhcp info for libvirt guests (to libvirt's internal dhcp server). + +I'm thinking something along the lines of + + Libvirt.dhcp "default" (MAC "52:54:00:00:00:01") (IPv4 "192.168.122.31") + +where I guess the MAC (or a better name?) has to be defined. "default" is the libvirt network name. +That property (and the undo) would translate into some call to "virsh net-update". + +This presumably needs a way to assign a matching MAC to the guest. We could maybe provide a convenience API that did both to avoid mismatches. + +I don't so far see a nice way to update the mac address on the guest. There is a --network mac= for virt-install, so maybe an optional parameter for defined? I guess it needs to be different function, called by defined to avoid breaking API? + + diff --git a/doc/todo/use_ghc_8.0_custom_compile_errors.mdwn b/doc/todo/use_ghc_8.0_custom_compile_errors.mdwn @@ -6,22 +6,27 @@ For example, a RevertableProperty is sometimes used where only a regular Property is accepted. In this case, the error could suggest that the user apply `setupRevertableProperty` to extract the setup side of the RevertableProperty. +> I tried this, it didn't seem worth the complication however. --[[Joey]] + And, when a Property HasInfo is provided to ensureProperty, propellor could explain, in the compile error, why it can't let the user do that. -Custom errors need a type class to be used. So, could do something like this: - - class NeedsProperty a where - withProperty :: (Property metatype -> b) -> b +> Done this and also used custom errors when properties' types don't let +> them be combined. --[[Joey]] - instance NeedsProperty (Property metatype) where withProperty = id +The new type-errors library builds a lot of stuff on top of this. +Its ability to detect "stuckness" seems like it may be able to catch +the very long type errors that we sometimes see when using propellor, and +whittle them down to a more useful error. --[[Joey]] - instance TypeError (Text "Use setupRevertableProperty ...") - => NeedsProperty RevertableProperty where - withProperty = error "unreachable" +> > Actually I think the stuckness would not help with that, though it +> > could help with other mistakes. In particular, forgetting to provide +> > a parameter to a property constructor can lead to a massive +> > error message that leaks type family stuff from MetaTypes, due to +> > the type checker getting stuck. Detecting that and replacing it with +> > a simpler error would be a big improvement. Such large error messages +> > can make ghc use an excessive amount of memory. --[[Joey]] -(While propellor needs to be buildable with older versions of ghc, -the `instance TypeError` can just be wrapped in an ifdef to make it only be -used by the new ghc.) +now [[done]]! --[[Joey]] [[!tag user/joey]] diff --git a/doc/todo/virtio-fs_image_type_for_Propellor.Property.Libvirt.mdwn b/doc/todo/virtio-fs_image_type_for_Propellor.Property.Libvirt.mdwn @@ -0,0 +1,3 @@ +Seems that [the new virtio-fs](https://lwn.net/Articles/788333/) can be used for [the root filesystem of a libvirt VM](https://virtio-fs.gitlab.io/howto-boot.html). That would allow propellor to keep updating the filesystem as it would just be a chroot on the KVM host, rather than an opaque image file. + +--spwhitton diff --git a/joeyconfig.hs b/joeyconfig.hs @@ -417,7 +417,8 @@ keysafe = host "keysafe.joeyh.name" $ props & Apt.serviceInstalledRunning "swapspace" & Cron.runPropellor (Cron.Times "30 * * * *") & Apt.installed ["etckeeper", "sudo"] - & Apt.removed ["nfs-common", "exim4", "exim4-base", "exim4-daemon-light", "rsyslog", "acpid", "rpcbind", "at"] + & JoeySites.noExim + & Apt.removed ["nfs-common", "rsyslog", "acpid", "rpcbind", "at"] & User.hasSomePassword (User "root") & User.accountFor (User "joey") @@ -525,13 +526,14 @@ standardSystemUnhardened suite arch motd = propertyList "standard system" $ prop & Apt.installed ["vim", "screen", "less"] & Cron.runPropellor (Cron.Times "30 * * * *") -- I use postfix, or no MTA. - & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] - `onChange` Apt.autoRemove + & JoeySites.noExim -- This is my standard container setup, Featuring automatic upgrades. standardContainer :: DebianSuite -> Property (HasInfo + Debian) standardContainer suite = propertyList "standard container" $ props & osDebian suite X86_64 + -- Do not want to run mail daemon inside a random container.. + & JoeySites.noExim & Apt.stdSourcesList `onChange` Apt.upgrade & Apt.unattendedUpgrades & Apt.cacheCleaned diff --git a/propellor.cabal b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 5.8.0 +Version: 5.9.0 Cabal-Version: 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> @@ -35,11 +35,12 @@ Description: . It is configured using haskell. +Flag WithTypeErrors + Description: Build with type-errors library for better error messages + Library Default-Language: Haskell98 GHC-Options: -Wall -fno-warn-tabs -O0 - if impl(ghc >= 8.0) - GHC-Options: -fno-warn-redundant-constraints Default-Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: @@ -49,6 +50,9 @@ Library directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable + if flag(WithTypeErrors) + Build-Depends: type-errors + CPP-Options: -DWITH_TYPE_ERRORS Exposed-Modules: Propellor diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -8,7 +9,7 @@ module Propellor.EnsureProperty ( ensureProperty , property' , OuterMetaTypesWitness - , Cannot_ensureProperty_WithInfo + , EnsurePropertyAllowed ) where import Propellor.Types @@ -16,6 +17,9 @@ import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Exception +import GHC.TypeLits +import GHC.Exts (Constraint) +import Data.Type.Bool import Data.Monoid import Prelude @@ -41,19 +45,40 @@ ensureProperty -- -Wredundant-constraints is turned off because -- this constraint appears redundant, but is actually -- crucial. - ( Cannot_ensureProperty_WithInfo inner ~ 'True - , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine - ) + ( EnsurePropertyAllowed inner outer) => OuterMetaTypesWitness outer -> Property (MetaTypes inner) -> Propellor Result ensureProperty _ = maybe (return NoChange) catchPropellor . getSatisfy --- The name of this was chosen to make type errors a bit more understandable. -type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool where - Cannot_ensureProperty_WithInfo '[] = 'True - Cannot_ensureProperty_WithInfo (t ': ts) = - Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts +type family EnsurePropertyAllowed inner outer :: Constraint where + EnsurePropertyAllowed inner outer = 'True ~ + ((EnsurePropertyNoInfo inner) + && + (EnsurePropertyTargetOSMatches inner outer)) + +type family EnsurePropertyNoInfo (l :: [a]) :: Bool where + EnsurePropertyNoInfo '[] = 'True + EnsurePropertyNoInfo (t ': ts) = If (Not (t `EqT` 'WithInfo)) + (EnsurePropertyNoInfo ts) + (TypeError ('Text "Cannot use ensureProperty with a Property that HasInfo.")) + +type family EnsurePropertyTargetOSMatches inner outer where + EnsurePropertyTargetOSMatches inner outer = + If (Targets outer `IsSubset` Targets inner) + 'True + (IfStuck (Targets outer) + (DelayError + ('Text "ensureProperty outer Property type is not able to be inferred here." + ':$$: 'Text "Consider adding a type annotation." + ) + ) + (DelayErrorFcf + ('Text "ensureProperty inner Property is missing support for: " + ':$$: PrettyPrintMetaTypes (Difference (Targets outer) (Targets inner)) + ) + ) + ) -- | Constructs a property, like `property`, but provides its -- `OuterMetaTypesWitness`. diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs @@ -19,6 +19,7 @@ import Propellor.Types.MetaTypes import Propellor.Types.Core import Propellor.Property +import GHC.TypeLits import Data.Monoid import Prelude @@ -45,6 +46,16 @@ type family GetMetaTypes x where GetMetaTypes (Property (MetaTypes t)) = MetaTypes t GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t +-- When many properties are combined, ghc error message +-- can include quite a lot of code, typically starting with +-- `props and including all the properties up to and including the +-- one that fails to combine. Point the user in the right direction. +type family NoteFor symbol :: ErrorMessage where + NoteFor symbol = + 'Text "Probably the problem is with the last property added with " + ':<>: symbol + ':<>: 'Text " in the code excerpt below." + -- | Adds a property to a Props. -- -- Can add Properties and RevertableProperties @@ -55,7 +66,7 @@ type family GetMetaTypes x where -- this constraint appears redundant, but is actually -- crucial. , MetaTypes y ~ GetMetaTypes p - , CheckCombinable x y ~ 'CanCombine + , CheckCombinableNote x y (NoteFor ('Text "&")) ) => Props (MetaTypes x) -> p @@ -70,7 +81,7 @@ Props c & p = Props (c ++ [toChildProperty p]) -- this constraint appears redundant, but is actually -- crucial. , MetaTypes y ~ GetMetaTypes p - , CheckCombinable x y ~ 'CanCombine + , CheckCombinableNote x y (NoteFor ('Text "&^")) ) => Props (MetaTypes x) -> p @@ -82,7 +93,7 @@ Props c &^ p = Props (toChildProperty p : c) -- -Wredundant-constraints is turned off because -- this constraint appears redundant, but is actually -- crucial. - :: (CheckCombinable x z ~ 'CanCombine) + :: CheckCombinableNote x z (NoteFor ('Text "!")) => Props (MetaTypes x) -> RevertableProperty (MetaTypes y) (MetaTypes z) -> Props (MetaTypes (Combine x z)) diff --git a/src/Propellor/Property/Aiccu.hs b/src/Propellor/Property/Aiccu.hs @@ -47,8 +47,7 @@ hasConfig :: TunnelId -> UserName -> Property (HasInfo + DebianLike) hasConfig t u = prop `onChange` restarted where prop :: Property (HasInfo + UnixLike) - prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $ - property' "aiccu configured" . writeConfig - writeConfig getpassword w = getpassword $ ensureProperty w . go + prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $ \getpassword -> + property' "aiccu configured" $ \w -> getpassword $ ensureProperty w . go go (Password u', p) = confPath `File.hasContentProtected` config u' t p go (f, _) = error $ "Unexpected type of privdata: " ++ show f diff --git a/src/Propellor/Property/Atomic.hs b/src/Propellor/Property/Atomic.hs @@ -46,10 +46,8 @@ type CheckAtomicResourcePair a = AtomicResourcePair a -> Propellor (AtomicResour -- inactiveAtomicResource, and if it was successful, -- atomically activating that resource. atomicUpdate - -- Constriaints inherited from ensureProperty. - :: ( Cannot_ensureProperty_WithInfo t ~ 'True - , (Targets t `NotSuperset` Targets t) ~ 'CanCombine - ) + -- Constriaint inherited from ensureProperty. + :: EnsurePropertyAllowed t t => SingI t => AtomicResourcePair a -> CheckAtomicResourcePair a @@ -92,10 +90,8 @@ atomicUpdate rbase rcheck rswap mkp = property' d $ \w -> do -- children: a symlink with the name of the directory itself, and two copies -- of the directory, with names suffixed with ".1" and ".2" atomicDirUpdate - -- Constriaints inherited from ensureProperty. - :: ( Cannot_ensureProperty_WithInfo t ~ 'True - , (Targets t `NotSuperset` Targets t) ~ 'CanCombine - ) + -- Constriaint inherited from ensureProperty. + :: EnsurePropertyAllowed t t => SingI t => FilePath -> (FilePath -> Property (MetaTypes t)) diff --git a/src/Propellor/Property/Libvirt.hs b/src/Propellor/Property/Libvirt.hs @@ -34,7 +34,7 @@ data DiskImageType = Raw -- TODO: | QCow2 -- | Install basic libvirt components installed :: Property DebianLike -installed = Apt.installed ["libvirt-clients", "virtinst"] +installed = Apt.installed ["libvirt-clients", "virtinst", "libvirt-daemon", "libvirt-daemon-system"] -- | Ensure that the default libvirt network is set to autostart, and start it. -- diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -910,15 +910,16 @@ house user hosts ctx sshkey = propertyList "home automation" $ props & Systemd.enabled setupservicename `requires` setupserviceinstalled `onChange` Systemd.started setupservicename - & Systemd.enabled watchdogservicename - `requires` watchdogserviceinstalled - `onChange` Systemd.started watchdogservicename & Systemd.enabled pollerservicename `requires` pollerserviceinstalled `onChange` Systemd.started pollerservicename & Systemd.enabled controllerservicename `requires` controllerserviceinstalled `onChange` Systemd.started controllerservicename + & Systemd.enabled watchdogservicename + `requires` watchdogserviceinstalled + `onChange` Systemd.started watchdogservicename + & Apt.serviceInstalledRunning "watchdog" & User.hasGroup user (Group "dialout") & Group.exists (Group "gpio") Nothing & User.hasGroup user (Group "gpio") @@ -1025,7 +1026,7 @@ house user hosts ctx sshkey = propertyList "home automation" $ props ] -- Any changes to the rsync command will need my .authorized_keys -- rsync server command to be updated too. - rsynccommand = "rsync -e 'ssh -i" ++ sshkeyfile ++ "' -avz rrds/ joey@kitenet.net:/srv/web/house.joeyh.name/rrds/" + rsynccommand = "rsync -e 'ssh -i" ++ sshkeyfile ++ "' -avz rrds/ joey@kitenet.net:/srv/web/house.joeyh.name/rrds/ >/dev/null 2>&1" websitesymlink :: Property UnixLike websitesymlink = check (not . isSymbolicLink <$> getSymbolicLinkStatus "/var/www/html") @@ -1321,3 +1322,7 @@ rsyncNetBorgRepo d os = Borg.BorgRepoUsing os' ("2318@usw-s002.rsync.net:" ++ d) where -- rsync.net has a newer borg here os' = Borg.UsesEnvVar ("BORG_REMOTE_PATH", "borg1") : os + +noExim :: Property DebianLike +noExim = Apt.removed ["exim4", "exim4-base", "exim4-daemon-light"] + `onChange` Apt.autoRemove diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs @@ -391,6 +391,7 @@ mungename = replace "/" "_" containerCfg :: String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) containerCfg p = RevertableProperty (mk True) (mk False) where + mk :: Bool -> Property (HasInfo + Linux) mk b = tightenTargets $ pureInfoProperty desc $ mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] } diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs @@ -172,20 +172,22 @@ hiddenServiceData hn context = combineProperties desc $ props where desc = unwords ["hidden service data available in", varLib </> hn] installonion :: FilePath -> Property (HasInfo + DebianLike) - installonion f = withPrivData (PrivFile $ varLib </> hn </> f) context $ \getcontent -> - property' desc $ \w -> getcontent $ install w $ varLib </> hn </> f - install w f privcontent = ifM (liftIO $ doesFileExist f) - ( noChange - , ensureProperty w $ propertyList desc $ toProps - [ property desc $ makeChange $ do - createDirectoryIfMissing True (takeDirectory f) - writeFileProtected f (unlines (privDataLines privcontent)) - , File.mode (takeDirectory f) $ combineModes - [ownerReadMode, ownerWriteMode, ownerExecuteMode] - , File.ownerGroup (takeDirectory f) user (userGroup user) - , File.ownerGroup f user (userGroup user) - ] - ) + installonion basef = + let f = varLib </> hn </> basef + in withPrivData (PrivFile f) context $ \getcontent -> + property' desc $ \w -> getcontent $ \privcontent -> + ifM (liftIO $ doesFileExist f) + ( noChange + , ensureProperty w $ propertyList desc $ toProps + [ property desc $ makeChange $ do + createDirectoryIfMissing True (takeDirectory f) + writeFileProtected f (unlines (privDataLines privcontent)) + , File.mode (takeDirectory f) $ combineModes + [ownerReadMode, ownerWriteMode, ownerExecuteMode] + , File.ownerGroup (takeDirectory f) user (userGroup user) + , File.ownerGroup f user (userGroup user) + ] + ) restarted :: Property DebianLike restarted = Service.restarted "tor" diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -31,6 +32,7 @@ module Propellor.Types ( , HasInfo , type (+) , TightenTargets(..) + , TightenTargetsAllowed -- * Combining and modifying properties , Combines(..) , CombinedType @@ -44,6 +46,9 @@ module Propellor.Types ( , module Propellor.Types.ZFS ) where +import GHC.TypeLits hiding (type (+)) +import GHC.Exts (Constraint) +import Data.Type.Bool import qualified Data.Semigroup as Sem import Data.Monoid import Control.Applicative @@ -59,7 +64,7 @@ import Propellor.Types.MetaTypes import Propellor.Types.ZFS -- | The core data type of Propellor, this represents a property --- that the system should have, with a descrition, and an action to ensure +-- that the system should have, with a description, and an action to ensure -- it has the property. -- -- There are different types of properties that target different OS's, @@ -185,17 +190,17 @@ class Combines x y where -> y -> CombinedType x y -instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where +instance (CheckCombinable x y, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where combineWith f _ (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) = Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1) -instance (CheckCombinable x y ~ 'CanCombine, CheckCombinable x' y' ~ 'CanCombine, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where +instance (CheckCombinable x y, CheckCombinable x' y', SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = RevertableProperty (combineWith sf tf s1 s2) (combineWith tf sf t1 t2) -instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where +instance (CheckCombinable x y, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y -instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where +instance (CheckCombinable x y, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y class TightenTargets p where @@ -209,14 +214,31 @@ class TightenTargets p where -- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"] tightenTargets :: - -- Note that this uses PolyKinds - ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine - , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine + ( TightenTargetsAllowed untightened tightened , SingI tightened ) => p (MetaTypes untightened) -> p (MetaTypes tightened) +-- Note that this uses PolyKinds +type family TightenTargetsAllowed untightened tightened :: Constraint where + TightenTargetsAllowed untightened tightened = + If (Targets tightened `IsSubset` Targets untightened + && NonTargets untightened `IsSubset` NonTargets tightened) + ('True ~ 'True) + (IfStuck (Targets tightened) + (DelayError + ('Text "Unable to infer desired Property type in this use of tightenTargets." + ':$$: ('Text "Consider adding a type annotation.") + ) + ) + (DelayErrorFcf + ('Text "This use of tightenTargets would widen, not narrow, adding: " + ':$$: PrettyPrintMetaTypes (Difference (Targets tightened) (Targets untightened)) + ) + ) + ) + instance TightenTargets Property where tightenTargets (Property _ d a i c) = Property sing d a i c diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-} +{-# LANGUAGE TypeOperators, PolyKinds, DataKinds, ConstraintKinds #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-} +{-# LANGUAGE CPP #-} module Propellor.Types.MetaTypes ( MetaType(..), @@ -17,21 +19,40 @@ module Propellor.Types.MetaTypes ( IncludesInfo, Targets, NonTargets, - NotSuperset, + PrettyPrintMetaTypes, + IsSubset, Combine, - CheckCombine(..), CheckCombinable, + CheckCombinableNote, type (&&), Not, EqT, Union, + Intersect, + Difference, + IfStuck, + DelayError, + DelayErrorFcf, ) where import Propellor.Types.Singletons import Propellor.Types.OS +import GHC.TypeLits hiding (type (+)) +import GHC.Exts (Constraint) import Data.Type.Bool +#ifdef WITH_TYPE_ERRORS +import Type.Errors +#else +type family IfStuck (expr :: k) (b :: k1) (c :: k1) :: k1 where + IfStuck expr b c = c +type family DelayError msg where + DelayError msg = TypeError msg +type family DelayErrorFcf msg where + DelayErrorFcf msg = TypeError msg +#endif + data MetaType = Targeting TargetOS -- ^ A target OS of a Property | WithInfo -- ^ Indicates that a Property has associated Info @@ -113,41 +134,69 @@ type family Combine (list1 :: [a]) (list2 :: [a]) :: [a] where (Targets list1 `Intersect` Targets list2) ) --- | Checks if two MetaTypes lists can be safely combined. --- --- This should be used anywhere Combine is used, as an additional --- constraint. For example: --- --- > foo :: (CheckCombinable x y ~ 'CanCombine) => x -> y -> Combine x y -type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: CheckCombine where - -- As a special case, if either list is empty, let it be combined - -- with the other. This relies on MetaTypes list always containing - -- at least one target, so can only happen if there's already been - -- a type error. This special case lets the type checker show only - -- the original type error, and not an extra error due to a later - -- CheckCombinable constraint. - CheckCombinable '[] list2 = 'CanCombine - CheckCombinable list1 '[] = 'CanCombine - CheckCombinable (l1 ': list1) (l2 ': list2) = - CheckCombinable' (Combine (l1 ': list1) (l2 ': list2)) -type family CheckCombinable' (combinedlist :: [a]) :: CheckCombine where - CheckCombinable' '[] = 'CannotCombineTargets - CheckCombinable' (a ': rest) - = If (IsTarget a) - 'CanCombine - (CheckCombinable' rest) - -data CheckCombine = CannotCombineTargets | CanCombine +-- | Checks if two MetaTypes lists can be safly combined; +-- eg they have at least one Target in common. +type family IsCombinable (list1 :: [a]) (list2 :: [a]) :: Bool where + -- As a special case, if either list is empty or only WithInfo, + -- let it be combined with the other. This relies on MetaTypes + -- list always containing at least one Target, so can only happen + -- if there's already been a type error. This special case lets the + -- type checker show only the original type error, and not + -- subsequent errors due to later CheckCombinable constraints. + IsCombinable '[] list2 = 'True + IsCombinable list1 '[] = 'True + IsCombinable ('WithInfo ': list1) list2 = IsCombinable list1 list2 + IsCombinable list1 ('WithInfo ': list2) = IsCombinable list1 list2 + IsCombinable list1 list2 = + Not (Null (Combine (Targets list1) (Targets list2))) --- | Every item in the subset must be in the superset. +-- | This (or CheckCombinableNote) should be used anywhere Combine is used, +-- as an additional constraint. For example: -- --- The name of this was chosen to make type errors more understandable. -type family NotSuperset (superset :: [a]) (subset :: [a]) :: CheckCombine where - NotSuperset superset '[] = 'CanCombine - NotSuperset superset (s ': rest) = - If (Elem s superset) - (NotSuperset superset rest) - 'CannotCombineTargets +-- > foo :: CheckCombinable x y => x -> y -> Combine x y +type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: Constraint where + CheckCombinable list1 list2 = + If (IsCombinable list1 list2) + ('True ~ 'True) + (CannotCombine list1 list2 'Nothing) + +-- | Allows providing an additional note. +type family CheckCombinableNote (list1 :: [a]) (list2 :: [a]) (note :: ErrorMessage) :: Constraint where + CheckCombinableNote list1 list2 note = + If (IsCombinable list1 list2) + ('True ~ 'True) + (CannotCombine list1 list2 + ('Just ('Text "(" ':<>: note ':<>: 'Text ")")) + ) + +-- Checking IfStuck is to avoid massive and useless error message leaking +-- type families from this module. +type family CannotCombine (list1 :: [a]) (list2 :: [a]) (note :: Maybe ErrorMessage) :: Constraint where + CannotCombine list1 list2 note = + IfStuck list1 + (IfStuck list2 + (DelayError (CannotCombineMessage UnknownType UnknownType UnknownTypeNote)) + (DelayErrorFcf (CannotCombineMessage UnknownType (PrettyPrintMetaTypes list2) UnknownTypeNote)) + ) + (IfStuck list2 + (DelayError (CannotCombineMessage (PrettyPrintMetaTypes list1) UnknownType UnknownTypeNote)) + (DelayErrorFcf (CannotCombineMessage (PrettyPrintMetaTypes list1) (PrettyPrintMetaTypes list2) note)) + ) + +type family UnknownType :: ErrorMessage where + UnknownType = 'Text "<unknown>" + +type family UnknownTypeNote :: Maybe ErrorMessage where + UnknownTypeNote = 'Just ('Text "(Property <unknown> is often caused by applying a Property constructor to the wrong number of arguments.)") + +type family CannotCombineMessage (a :: ErrorMessage) (b :: ErrorMessage) (note :: Maybe ErrorMessage) :: ErrorMessage where + CannotCombineMessage a b ('Just note) = + CannotCombineMessage a b 'Nothing + ':$$: note + CannotCombineMessage a b 'Nothing = + 'Text "Cannot combine Properties:" + ':$$: ('Text " Property " ':<>: a) + ':$$: ('Text " Property " ':<>: b) type family IsTarget (a :: t) :: Bool where IsTarget ('Targeting a) = 'True @@ -167,6 +216,21 @@ type family NonTargets (l :: [a]) :: [a] where (NonTargets xs) (x ': NonTargets xs) +-- | Pretty-prints a list of MetaTypes for display in a type error message. +type family PrettyPrintMetaTypes (l :: [MetaType]) :: ErrorMessage where + PrettyPrintMetaTypes '[] = 'Text "<none>" + PrettyPrintMetaTypes (t ': '[]) = PrettyPrintMetaType t + PrettyPrintMetaTypes (t ': ts) = + PrettyPrintMetaType t ':<>: 'Text " + " ':<>: PrettyPrintMetaTypes ts + +type family PrettyPrintMetaType t :: ErrorMessage where + PrettyPrintMetaType 'WithInfo = 'ShowType HasInfo + PrettyPrintMetaType ('Targeting 'OSDebian) = 'ShowType Debian + PrettyPrintMetaType ('Targeting 'OSBuntish) = 'ShowType Buntish + PrettyPrintMetaType ('Targeting 'OSFreeBSD) = 'ShowType FreeBSD + PrettyPrintMetaType ('Targeting 'OSArchLinux) = 'ShowType ArchLinux + PrettyPrintMetaType ('Targeting t) = 'ShowType t + -- | Type level elem type family Elem (a :: t) (list :: [t]) :: Bool where Elem a '[] = 'False @@ -188,6 +252,28 @@ type family Intersect (list1 :: [a]) (list2 :: [a]) :: [a] where (a ': Intersect rest list2) (Intersect rest list2) +-- | Type level difference. Items that are in the first list, but not in +-- the second. +type family Difference (list1 :: [a]) (list2 :: [a]) :: [a] where + Difference '[] list2 = '[] + Difference (a ': rest) list2 = + If (Elem a list2) + (Difference rest list2) + (a ': Difference rest list2) + +-- | Every item in the subset must be in the superset. +type family IsSubset (subset :: [a]) (superset :: [a]) :: Bool where + IsSubset '[] superset = 'True + IsSubset (s ': rest) superset = + If (Elem s superset) + (IsSubset rest superset) + 'False + +-- | Type level null. +type family Null (list :: [a]) :: Bool where + Null '[] = 'True + Null l = 'False + -- | Type level equality of metatypes. type family EqT (a :: MetaType) (b :: MetaType) where EqT a a = 'True diff --git a/stack.yaml b/stack.yaml @@ -2,3 +2,6 @@ resolver: lts-9.21 packages: - '.' +extra-deps: +- type-errors-0.1.0.0 +- first-class-families-0.5.0.0