Compare commits

..

8 Commits

11 changed files with 524 additions and 642 deletions

View File

@ -11,16 +11,13 @@
#:use-module (gnu packages haskell-check)
#:use-module (gnu packages haskell-web)
#:use-module (gnu packages golang-web)
#:use-module (gnu packages ssh)
#:use-module (gnu packages version-control))
(define vcs-file?
(or (and=> (current-source-directory)
(lambda (dir)
(git-predicate (string-append dir "/../.."))))
(or (git-predicate (string-append (current-source-directory) "/../.."))
(const #t)))
(define tiedote-md*
(define-public tiedote-md
(package
(name "tiedote-md")
(version "0.0.1-git")
@ -31,7 +28,7 @@
(inputs (list ghc-acid-state
ghc-attoparsec
ghc-base64
ghc-crypton
ghc-cryptonite
ghc-case-insensitive
ghc-glob
ghc-purebred-email
@ -44,19 +41,17 @@
ghc-scotty
ghc-exit-codes
git
openssh-sans-x
go-github-com-aymerick-douceur))
(arguments
(list
#:phases
#~(modify-phases %standard-phases
(add-after 'install 'wrap-binaries
(lambda* (#:key inputs #:allow-other-keys)
(lambda _
(wrap-program
(string-append #$output "/bin/tiedote.md")
`("PATH" prefix (,(string-append (assoc-ref inputs "git") "/bin")
,(string-append (assoc-ref inputs "openssh-sans-x") "/bin")
,(string-append (assoc-ref inputs "go-github-com-aymerick-douceur")
`("PATH" prefix (,(string-append #$(this-package-input "git") "/bin")
,(string-append #$(this-package-input "go-github-com-aymerick-douceur")
"/bin")))))))))
(home-page "https://git.olarinmaensamoojat.fi/OMS/tiedote.md")
(synopsis "Git- ja markdown-pohjainen masssasähköpostijärjestelmä OMS:lle")
@ -67,53 +62,90 @@ sähköpostipohjaista käyttöliittymää. Toistaiseksi tiedote.md on kovakoodat
käyttämään OMS:n tiedotepohjia.")
(license license:agpl3+)))
(define ghc-template-haskell-lift
(define ghc-scotty
(package
(name "ghc-template-haskell-lift")
(version "0.1.0.0")
(source
(origin
(name "ghc-scotty")
(version "0.12")
(source (origin
(method url-fetch)
(uri (hackage-uri "template-haskell-lift" version))
(uri (hackage-uri "scotty" version))
(sha256
(base32 "09zilw0nbjmn1k688l058183rwa3br0fvh3x8jxqygjh3011w8ps"))))
(base32
"1lpggpdzgjk23mq7aa64yylds5dbm4ynhcvbarqihjxabvh7xmz1"))))
(build-system haskell-build-system)
(properties '((upstream-name . "template-haskell-lift")))
(inputs (list ghc-aeson
ghc-base-compat-batteries
ghc-blaze-builder
ghc-case-insensitive
ghc-data-default-class
ghc-fail
ghc-http-types
ghc-monad-control
ghc-nats
ghc-network
ghc-regex-compat
ghc-transformers-base
ghc-transformers-compat
ghc-wai
ghc-wai-extra
ghc-warp))
(native-inputs (list ghc-async ghc-hspec ghc-hspec-wai ghc-lifted-base hspec-discover))
(arguments
`(#:cabal-revision ("1"
"072g7a9b2sp0vc3g48xqbrxfis1rizqakz0b8064hs0cbgj3xkgn")))
(home-page "http://hackage.haskell.org/package/template-haskell-lift")
(synopsis "The 'Lift' typeclass.")
`(#:cabal-revision ("7"
"1i8icc612w4dbmqmnf99drqpmjvhjnkmqgk9xr63amj8jkz5lp4m")))
(home-page "https://github.com/scotty-web/scotty")
(synopsis
"Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp")
(description
"The stable home of @code{TemplateHaskell's} Lift typeclass, which implements
cross-stage persistence for Template Haskell.")
(license license:bsd-2)))
"This package provides a Haskell web framework inspired by Ruby's Sinatra, using
WAI and Warp. . @ {-# LANGUAGE OverloadedStrings #-} . import
Web.Scotty . import Data.Monoid (mconcat) . main = scotty 3000 $   get
&#34;/:word&#34; $ do &#32;&#32;&#32;&#32;beam <- param &#34;word&#34;
&#32;&#32;&#32;&#32;html $ mconcat [&#34;&#60;h1&#62;Scotty, &#34;, beam, &#34;
me up!&#60;/h1&#62;&#34;] @ . . Scotty is the cheap and cheerful way to write
RESTful, declarative web applications. . * A page is as simple as defining the
verb, url pattern, and Text content. . * It is template-language agnostic.
Anything that returns a Text value will do. . * Conforms to WAI Application
interface. . * Uses very fast Warp webserver by default. . As for the name:
Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
[Warp] <http://hackage.haskell.org/package/warp>")
(license license:bsd-3)))
(define ghc-doclayout*
(define ghc-hspec-wai
(package
(inherit ghc-doclayout)
(source
(origin
(inherit (package-source ghc-doclayout))
(patches
(list (local-file "../patches/ghc-doclayout-add-lift-instance.patch")))))
(inputs (modify-inputs (package-inputs ghc-doclayout)
(append ghc-template-haskell-lift)))))
(define-public tiedote-md
((package-input-rewriting `((,ghc-doclayout . ,ghc-doclayout*)))
tiedote-md*))
(name "ghc-hspec-wai")
(version "0.11.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "hspec-wai" version))
(sha256
(base32
"03wiksic5y9a2g6a86nsxrnajdgdvpv17w02h5qla0zp9zs6pa1j"))))
(build-system haskell-build-system)
(inputs (list ghc-quickcheck
ghc-base-compat
ghc-case-insensitive
ghc-hspec-core
ghc-hspec-expectations
ghc-http-types
ghc-wai
ghc-wai-extra))
(native-inputs (list ghc-hspec hspec-discover))
(home-page "https://github.com/hspec/hspec-wai#readme")
(synopsis "Experimental Hspec support for testing WAI applications")
(description "Experimental Hspec support for testing WAI applications")
(license license:expat)))
(define ghc-acid-state
(package
(name "ghc-acid-state")
(version "0.16.1.4")
(source
(origin
(version "0.16.1.2")
(source (origin
(method url-fetch)
(uri (hackage-uri "acid-state" version))
(sha256
(base32 "1z3q0d83dmdhr2s0bh4vhlyz82wik3w8gdmqs5mxk6kw6g7f0xzl"))))
(base32
"1ixg62liif1g18ggxap8zdhzy261fj5d24pmb0n36gfhz18b38bx"))))
(build-system haskell-build-system)
(properties '((upstream-name . "acid-state")))
(inputs (list ghc-cereal
@ -122,119 +154,71 @@ cross-stage persistence for Template Haskell.")
ghc-network
ghc-network-bsd
ghc-th-expand-syns))
(native-inputs (list hspec-discover ghc-hspec ghc-hedgehog))
(native-inputs (list ghc-hspec ghc-hspec-discover ghc-hedgehog))
(home-page "https://github.com/acid-state/acid-state")
(synopsis
"Add ACID guarantees to any serializable Haskell data structure.")
(synopsis "Add ACID guarantees to any serializable Haskell data structure.")
(description
"Use regular Haskell data structures as your database and get stronger ACID
guarantees than most RDBMS offer.")
guarantees than most RDBMS offer.")
(license license:public-domain)))
(define ghc-ap-normalize
(define ghc-safecopy
(package
(name "ghc-ap-normalize")
(version "0.1.0.1")
(source
(origin
(name "ghc-safecopy")
(version "0.10.4.2")
(source (origin
(method url-fetch)
(uri (hackage-uri "ap-normalize" version))
(uri (hackage-uri "safecopy" version))
(sha256
(base32 "1212zxc4qn6msk0w13yhrza2qjs79h78misllb4chng75jqi61l2"))))
(base32
"0r2mf0p82gf8vnldx477b5ykrj1x7hyg13nqfn6gzb50japs6h3i"))))
(build-system haskell-build-system)
(properties '((upstream-name . "ap-normalize")))
(arguments (list #:tests? #f))
(home-page "http://hackage.haskell.org/package/ap-normalize")
(synopsis "Self-normalizing applicative expressions")
(description
"An applicative functor transformer to normalize expressions using @@(\\<$>)@@,
@@(\\<*>)@@, and @@pure@@ into a linear list of actions. See
\"@code{ApNormalize}\" to get started.")
(license license:expat)))
(define ghc-concise
(package
(name "ghc-concise")
(version "0.1.0.1")
(source
(origin
(method url-fetch)
(uri (hackage-uri "concise" version))
(sha256
(base32 "09crgc6gjfidlad6263253xx1di6wfhc9awhira21s0z7rddy9sw"))))
(build-system haskell-build-system)
(properties '((upstream-name . "concise")))
(inputs (list ghc-lens))
(native-inputs (list ghc-tasty ghc-tasty-quickcheck ghc-quickcheck
ghc-quickcheck-instances))
(home-page "https://github.com/frasertweedale/hs-concise")
(synopsis "Utilities for Control.Lens.Cons")
(description
"concise provides a handful of functions to extend what you can do with
Control.Lens.Cons.")
(license license:bsd-3)))
(define ghc-exit-codes
(package
(name "ghc-exit-codes")
(version "1.0.0")
(source
(origin
(method url-fetch)
(uri (hackage-uri "exit-codes" version))
(sha256
(base32 "00cyli96zkyqhjr3lqzrislqyk72xwm2dcqvjagklidh32d4k8ja"))))
(build-system haskell-build-system)
(properties '((upstream-name . "exit-codes")))
(home-page "http://github.com/JustusAdam/exit-codes")
(synopsis "Exit codes as defined by BSD")
(description
"Expose the exit codes defined by BSD in sysexits.h to the Haskell world.")
(license license:bsd-3)))
(define ghc-filestore
(package
(name "ghc-filestore")
(version "0.6.5.1")
(source
(origin
(method url-fetch)
(uri (hackage-uri "filestore" version))
(sha256
(base32 "1m6rav1rcigckakw8ky27lbwh5a9q8xl7nvv358ljykmvyl1j2lc"))))
(build-system haskell-build-system)
(properties '((upstream-name . "filestore")))
(inputs (list ghc-utf8-string ghc-xml ghc-split ghc-diff ghc-old-locale))
(native-inputs (list ghc-hunit git-minimal/pinned mercurial))
(home-page "http://hackage.haskell.org/package/filestore")
(synopsis "Interface for versioning file stores.")
(description
"The filestore library provides an abstract interface for a versioning file
store, and modules that instantiate this interface. Currently Git, Darcs, and
Mercurial modules are provided, and other VCSs or databases could be added.")
(license license:bsd-3)))
(properties '((upstream-name . "safecopy")))
(inputs (list ghc-cereal
ghc-generic-data
ghc-old-time
ghc-vector))
(native-inputs (list ghc-lens
ghc-lens-action
ghc-tasty
ghc-tasty-quickcheck
ghc-quickcheck-instances
ghc-quickcheck
ghc-hunit))
(arguments
`(#:cabal-revision ("6"
"0ii5cdg4l4ww81p7gd5m3z2jdqrs2hvqhwzrlz267nzxbws00x0b")))
(home-page "https://github.com/acid-state/safecopy")
(synopsis "Binary serialization with version control.")
(description "An extension to Data.Serialize with built-in version control.")
(license license:public-domain)))
(define ghc-generic-data
(package
(name "ghc-generic-data")
(version "1.1.0.2")
(source
(origin
(version "1.0.0.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "generic-data" version))
(sha256
(base32 "1dfs728nbkilzfmdk6gnjk7wdk1habqn35pb071zcmcp8ll0lzpj"))))
(base32
"0fz65k4sxn9c23rg5iv0vij2mksl5rkn6dl2f3i9d9d60b5wca9y"))))
(build-system haskell-build-system)
(properties '((upstream-name . "generic-data")))
(inputs (list ghc-ap-normalize ghc-base-orphans ghc-show-combinators
ghc-contravariant))
(native-inputs (list ghc-generic-lens
(inputs (list ghc-ap-normalize
ghc-contravariant
ghc-show-combinators))
(native-inputs (list ghc-tasty
ghc-tasty-hunit
ghc-tasty
ghc-tasty-hunit
ghc-tasty
ghc-tasty-hunit
ghc-generic-lens
ghc-tasty
ghc-tasty-hunit
ghc-generic-lens
ghc-one-liner))
(arguments
`(#:cabal-revision ("1"
"0f2aijk70cb01p8yzbg5jq4gawnaryg8qnb1jx4xx92mfmn673p8")))
(home-page "https://github.com/Lysxia/generic-data#readme")
(synopsis "Deriving instances with GHC.Generics and related utilities")
(description
@ -246,12 +230,12 @@ representations to help using \"GHC.Generics\". See README.")
(package
(name "ghc-lens-action")
(version "0.2.6")
(source
(origin
(source (origin
(method url-fetch)
(uri (hackage-uri "lens-action" version))
(sha256
(base32 "0cdprc5j6r976dmrga2zwvcr7qsv7nqy3nvncp66yyy0dk2qlwm3"))))
(base32
"0cdprc5j6r976dmrga2zwvcr7qsv7nqy3nvncp66yyy0dk2qlwm3"))))
(build-system haskell-build-system)
(properties '((upstream-name . "lens-action")))
(inputs (list ghc-lens ghc-comonad ghc-contravariant ghc-profunctors
@ -266,94 +250,92 @@ representations to help using \"GHC.Generics\". See README.")
folds as split off from the original lens package.")
(license license:bsd-3)))
(define ghc-linear-base
(define ghc-ap-normalize
(package
(name "ghc-linear-base")
(version "0.5.0")
(source
(origin
(name "ghc-ap-normalize")
(version "0.1.0.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "linear-base" version))
(uri (hackage-uri "ap-normalize" version))
(sha256
(base32 "0iikqp73i0isxkd8xwg5f8f6dk3cv5iw6ifjkmp5r5kwxb650xgq"))))
(base32
"1212zxc4qn6msk0w13yhrza2qjs79h78misllb4chng75jqi61l2"))))
(build-system haskell-build-system)
(properties '((upstream-name . "linear-base")))
(inputs (list ghc-hashable ghc-linear-generics ghc-storable-tuple
ghc-vector ghc-primitive))
(native-inputs (list ghc-inspection-testing
ghc-tasty-inspection-testing
ghc-tasty
ghc-tasty-hedgehog
ghc-mmorph
ghc-hedgehog))
(home-page "https://github.com/tweag/linear-base#README")
(synopsis "Standard library for linear types.")
(description "Please see README.md.")
(properties '((upstream-name . "ap-normalize")))
(native-inputs (list ghc-inspection-testing ghc-inspection-testing))
(home-page "http://hackage.haskell.org/package/ap-normalize")
(synopsis "Self-normalizing applicative expressions")
(description
"An applicative functor transformer to normalize expressions using @@(\\<$>)@@,
@@(\\<*>)@@, and @@pure@@ into a linear list of actions. See \"ApNormalize\" to
get started.")
(license license:expat)))
(define ghc-linear-generics
(define ghc-show-combinators
(package
(name "ghc-linear-generics")
(version "0.2.3")
(source
(origin
(name "ghc-show-combinators")
(version "0.2.0.0")
(source (origin
(method url-fetch)
(uri (hackage-uri "linear-generics" version))
(uri (hackage-uri "show-combinators" version))
(sha256
(base32 "0093ywl8s8k92b50li28gcmqc616f6l7jkv7vslkvqzn42yrvbq2"))))
(base32
"07ds87ldl9165hj3k5h84iawc6vqlbggni3dg1nhbxww1spxn0n9"))))
(build-system haskell-build-system)
(properties '((upstream-name . "linear-generics")))
(inputs (list ghc-th-abstraction))
(native-inputs (list hspec-discover ghc-hspec))
(properties '((upstream-name . "show-combinators")))
(arguments
`(#:cabal-revision ("4"
"1wxb2r70bn1rhs771jlq08q1wvaf7risn6y931snaxa0xwi6a4zq")))
(home-page "https://github.com/linear-generics/linear-generics")
(synopsis "Generic programming library for generalised deriving.")
`(#:cabal-revision ("2"
"0n3xlpm41wpw1ybmacg9s7150nx00qrdlw2rq4fzz7iw7333cyjx")))
(home-page "https://github.com/Lysxia/show-combinators#readme")
(synopsis "Combinators to write Show instances")
(description
"This package offers a version of
<https://hackage.haskell.org/package/base/docs/GHC-Generics.html GHC.Generics>
with two important improvements: . 1. The @@to@@, @@from@@, @@to1@@, and
@@from1@@ methods have multiplicity-polymorphic types, allowing them to be used
with either traditional Haskell code or linearly typed code. . 2. The
representations used for @@Generic1@@ are modified slightly. As a result,
@@to1@@ and @@from1@@ never need to use @@fmap@@. This can
<https://gitlab.haskell.org/ghc/ghc/-/issues/15969 greatly improve performance>,
and it is <https://github.com/tweag/linear-base/pull/316 necessary to support
multiplicity polymorphism>. A smaller change, approximately
<https://gitlab.haskell.org/ghc/ghc/-/issues/7492 as proposed by spl>, reduces
the number of instances that must be written to actually use @@Generic1@@ for
deriving instances of other classes. . For more details, see the
\"Generics.Linear\" documentation. . The implementation is based on the
@@generic-deriving@@ package, first described in the paper . * /A generic
deriving mechanism for Haskell/. Jose Pedro Magalhaes, Atze Dijkstra, Johan
Jeuring, and Andres Loeh. Haskell'10. . This library is organized as follows:
. * \"Generics.Linear\" defines the core functionality for generics, including the
multiplicity-polymorphic @@Generic(1)@@ classes and a replacement for the
@@:.:@@ composition type. . * \"Generics.Linear.TH\" implements Template Haskell
functionality for deriving instances of @@Generic(1)@@. . *
\"Generics.Linear.Unsafe.@code{ViaGHCGenerics}\" offers @code{@@DerivingVia}@@
targets to derive @@Generic@@ and @@Generic1@@ instances from
@@\"GHC.Generics\".'GHC.Generics.Generic'@@. Because these instances necessarily
use unsafe coercions, their use will likely inhibit full optimization of code
using them. . Educational code: the educational modules exported by
<https://hackage.haskell.org/package/generic-deriving generic-deriving> have
been copied into the @@tests\\/Generic\\/Deriving@@ directory in this repository,
with the very few modifications required to accommodate the differences between
the @@Generic1@@ representations here and in @@base@@. All the same caveats
apply as in the originals; see that package's @@README@@.")
"This package provides a minimal pretty-printing library for Show instances in
Haskell.")
(license license:expat)))
(define ghc-generic-lens
(package
(name "ghc-generic-lens")
(version "2.2.2.0")
(source (origin
(method url-fetch)
(uri (hackage-uri "generic-lens" version))
(sha256
(base32
"0s4b51s11ssmndmx9m9zbwgv9rb27ajwihsrk10hn582rp4ck3c6"))))
(build-system haskell-build-system)
(properties '((upstream-name . "generic-lens")))
(inputs (list ghc-generic-lens-core ghc-profunctors))
(native-inputs (list ghc-lens
ghc-inspection-testing
ghc-hunit
ghc-lens
ghc-hunit
ghc-lens
ghc-hunit
ghc-doctest
ghc-lens))
(home-page "https://github.com/kcsongor/generic-lens")
(synopsis "Generically derive traversals, lenses and prisms.")
(description
"This library uses GHC.Generics to derive efficient optics (traversals, lenses
and prisms) for algebraic data types in a type-directed way, with a focus on
good type inference and error messages when possible. The library exposes a
van Laarhoven interface. For an alternative interface, supporting an opaque
optic type, see @@<https://hackage.haskell.org/package/generic-optics
generic-optics>@@.")
(license license:bsd-3)))
(define ghc-one-liner
(package
(name "ghc-one-liner")
(version "2.1")
(source
(origin
(source (origin
(method url-fetch)
(uri (hackage-uri "one-liner" version))
(sha256
(base32 "09gdivd38disddxs42179vmgca0yzk5dfm6ygicgl5l25qbizrfh"))))
(base32
"09gdivd38disddxs42179vmgca0yzk5dfm6ygicgl5l25qbizrfh"))))
(build-system haskell-build-system)
(properties '((upstream-name . "one-liner")))
(inputs (list ghc-contravariant ghc-bifunctors ghc-profunctors ghc-tagged
@ -369,16 +351,155 @@ apply as in the originals; see that package's @@README@@.")
particularly useful for writing default implementations of type class methods.")
(license license:bsd-3)))
(define ghc-generic-lens-core
(package
(name "ghc-generic-lens-core")
(version "2.2.1.0")
(source (origin
(method url-fetch)
(uri (hackage-uri "generic-lens-core" version))
(sha256
(base32
"08i4c9yb6z84iknrnl9f3f343121j7ilp0a679v81nsjm9xz3rlf"))))
(build-system haskell-build-system)
(properties '((upstream-name . "generic-lens-core")))
(inputs (list ghc-indexed-profunctors))
(arguments
`(#:cabal-revision ("1"
"1dbjhd6k7ypqa9f4h9v2xndgb4mjhfli3n1vjm8r8ga0kfndbqfn")))
(home-page "https://github.com/kcsongor/generic-lens")
(synopsis "Generically derive traversals, lenses and prisms.")
(description
"This library uses GHC.Generics to derive efficient optics (traversals, lenses
and prisms) for algebraic data types in a type-directed way, with a focus on
good type inference and error messages when possible. This package is the
shared internal logic of the @@<https://hackage.haskell.org/package/generic-lens
generic-lens>@@ and @@<https://hackage.haskell.org/package/generic-optics
generic-optics>@@ libraries.")
(license license:bsd-3)))
(define ghc-indexed-profunctors
(package
(name "ghc-indexed-profunctors")
(version "0.1.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "indexed-profunctors" version))
(sha256
(base32
"1cbccbvrx73drr1jf3yyw0rp1mcfv3jc1rvdcby5xxx4ja543fjs"))))
(build-system haskell-build-system)
(properties '((upstream-name . "indexed-profunctors")))
(home-page "http://hackage.haskell.org/package/indexed-profunctors")
(synopsis "Utilities for indexed profunctors")
(description
"This package contains basic definitions related to indexed profunctors. These
are primarily intended as internal utilities to support the @@optics@@ and
@@generic-lens@@ package families.")
(license license:bsd-3)))
(define ghc-linear-base
(package
(name "ghc-linear-base")
(version "0.3.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "linear-base" version))
(sha256
(base32
"1gm8bwyi39x5x29xb6nq13x9x9p30vm29s11k4pkcql70sj4pv0h"))))
(build-system haskell-build-system)
(properties '((upstream-name . "linear-base")))
(inputs (list ghc-hashable ghc-linear-generics ghc-storable-tuple ghc-vector
ghc-primitive))
(native-inputs (list ghc-inspection-testing
ghc-tasty-inspection-testing
ghc-hedgehog
ghc-tasty
ghc-tasty-hedgehog
ghc-mmorph
ghc-tasty
ghc-tasty-hedgehog
ghc-hedgehog))
(arguments
`(#:cabal-revision ("1"
"153nkw2i7n22xzfj8q2xmzsh77pr7pay8v3gc1xli491qmsc0fcd")))
(home-page "https://github.com/tweag/linear-base#README")
(synopsis "Standard library for linear types.")
(description "Please see README.md.")
(license license:expat)))
(define ghc-linear-generics
(package
(name "ghc-linear-generics")
(version "0.2.2")
(source (origin
(method url-fetch)
(uri (hackage-uri "linear-generics" version))
(sha256
(base32
"0ls571qzayky0dax9d209lw9wv344z3969daqcsncv0r5rlvlps9"))))
(build-system haskell-build-system)
(properties '((upstream-name . "linear-generics")))
(inputs (list ghc-th-abstraction-0.5))
(native-inputs (list ghc-hspec hspec-discover))
(home-page "https://github.com/linear-generics/linear-generics")
(synopsis "Generic programming library for generalised deriving.")
(description
"This package offers a version of
<https://hackage.haskell.org/package/base/docs/GHC-Generics.html GHC.Generics>
with two important improvements: 1. The @@to@@, @@from@@, @@to1@@, and
@@from1@@ methods have multiplicity-polymorphic types, allowing them to be used
with either traditional Haskell code or linearly typed code. 2. The
representations used for @@Generic1@@ are modified slightly.")
(license license:bsd-3)))
(define ghc-th-abstraction-0.5
(package
(inherit ghc-th-abstraction)
(version "0.5.0.0")
(source (origin
(method url-fetch)
(uri (hackage-uri "th-abstraction" version))
(sha256
(base32
"0r4ri85283i1jjhd94wa9nps6cd9a8mh6rr4ds1gb2hqnwxdqn42"))))))
(define ghc-filestore
(package
(name "ghc-filestore")
(version "0.6.5")
(source (origin
(method url-fetch)
(uri (hackage-uri "filestore" version))
(sha256
(base32
"0z29273vdqjsrj4vby0gp7d12wg9nkzq9zgqg18db0p5948jw1dh"))))
(build-system haskell-build-system)
(properties '((upstream-name . "filestore")))
(inputs (list ghc-utf8-string ghc-xml ghc-split ghc-diff ghc-old-locale git mercurial))
(native-inputs (list ghc-hunit))
(arguments
`(#:cabal-revision ("1"
"1v9xqm0112knv6za05qf310ldndrc0h3xhajgwjaycbzkrknz4n7")))
(home-page "http://hackage.haskell.org/package/filestore")
(synopsis "Interface for versioning file stores.")
(description
"The filestore library provides an abstract interface for a versioning file
store, and modules that instantiate this interface. Currently Git, Darcs, and
Mercurial modules are provided, and other VCSs or databases could be added.")
(license license:bsd-3)))
(define ghc-purebred-email
(package
(name "ghc-purebred-email")
(version "0.7")
(source
(origin
(version "0.6.0.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "purebred-email" version))
(sha256
(base32 "1rw72rjji7bclql975gqpbisapjgzzywydql6p6b1v0ivzpsaq3s"))))
(base32
"0gdzdbxgsyps8hqd903bsyja0cr6kbklkicvma62q48wv0y7230j"))))
(build-system haskell-build-system)
(properties '((upstream-name . "purebred-email")))
(inputs (list ghc-attoparsec
@ -412,110 +533,48 @@ and forward/bounce - Content transfer and charset decoding/encoding - MIME
message header extensions for non-ASCII text
(<https://tools.ietf.org/html/rfc2047 RFC 2047>) - MIME parameter value and
encoded word extensions (<https://tools.ietf.org/html/rfc2231 RFC 2231>) -
@@Content-Disposition@@ header field (<https://tools.ietf.org/html/rfc2183 RFC
2183>) - Address syntax in @@From@@ and @@Sender@@ fields
(<https://tools.ietf.org/html/rfc6854 RFC 6854>) - @@Author@@ header field
(<https://tools.ietf.org/html/rfc9057 RFC 9057>).")
@@Content-Disposition@@ header field (<https://tools.ietf.org/html/rfc2183 RFC 2183>) - Address syntax in @@From@@ and @@Sender@@ fields
(<https://tools.ietf.org/html/rfc6854 RFC 6854>)")
(license license:agpl3+)))
(define ghc-safecopy
(define ghc-concise
(package
(name "ghc-safecopy")
(version "0.10.4.3")
(source
(origin
(name "ghc-concise")
(version "0.1.0.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "safecopy" version))
(uri (hackage-uri "concise" version))
(sha256
(base32 "03hkb4znm7jaszz290hqal3zbmw3606gafrbdxrvlcfkrpg1m71c"))))
(base32
"09crgc6gjfidlad6263253xx1di6wfhc9awhira21s0z7rddy9sw"))))
(build-system haskell-build-system)
(properties '((upstream-name . "safecopy")))
(inputs (list ghc-cereal ghc-generic-data ghc-old-time ghc-vector))
(native-inputs (list ghc-lens ghc-lens-action ghc-tasty
ghc-tasty-quickcheck ghc-hunit))
(home-page "https://github.com/acid-state/safecopy")
(synopsis "Binary serialization with version control.")
(properties '((upstream-name . "concise")))
(inputs (list ghc-lens))
(native-inputs (list ghc-tasty ghc-tasty-quickcheck ghc-quickcheck
ghc-quickcheck-instances))
(home-page "https://github.com/frasertweedale/hs-concise")
(synopsis "Utilities for Control.Lens.Cons")
(description
"An extension to Data.Serialize with built-in version control.")
(license license:public-domain)))
(define ghc-scotty
(package
(name "ghc-scotty")
(version "0.22")
(source
(origin
(method url-fetch)
(uri (hackage-uri "scotty" version))
(sha256
(base32 "075qnj3s1ddq337qcbrgwsc12rgjm1g5p755iaf67k824p0rifff"))))
(build-system haskell-build-system)
(properties '((upstream-name . "scotty")))
(inputs (list ghc-aeson
ghc-blaze-builder
ghc-case-insensitive
ghc-cookie
ghc-data-default-class
ghc-http-types
ghc-monad-control
ghc-network
ghc-regex-compat
ghc-resourcet
ghc-transformers-base
ghc-unliftio
ghc-wai
ghc-wai-extra
ghc-warp
ghc-fail
ghc-nats))
(native-inputs (list hspec-discover
ghc-async
ghc-hspec
ghc-hspec-wai
ghc-lifted-base
ghc-doctest
ghc-http-client))
(arguments
`(#:cabal-revision ("2"
"1m3qvb5q6yigw6ijxnp6h66rmyqg54619hb240s7cqc9qjrrkixk")))
(home-page "https://github.com/scotty-web/scotty")
(synopsis
"Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp")
(description
"This package provides a Haskell web framework inspired by Ruby's Sinatra, using
WAI and Warp. . @@ &#123;-&#35; LANGUAGE @code{OverloadedStrings} &#35;-&#125; .
import Web.Scotty . main = scotty 3000 $ &#32;&#32;get &#34;/:word&#34; $ do
&#32;&#32;&#32;&#32;beam <- @code{pathParam} &#34;word&#34;
&#32;&#32;&#32;&#32;html $ mconcat [&#34;&#60;h1&#62;Scotty, &#34;, beam, &#34;
me up!&#60;/h1&#62;&#34;] @@ . . Scotty is the cheap and cheerful way to write
RESTful, declarative web applications. . * A page is as simple as defining the
verb, url pattern, and Text content. . * It is template-language agnostic.
Anything that returns a Text value will do. . * Conforms to WAI Application
interface. . * Uses very fast Warp webserver by default. . As for the name:
Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
[Warp] <http://hackage.haskell.org/package/warp>.")
"concise provides a handful of functions to extend what you can do with
Control.Lens.Cons.")
(license license:bsd-3)))
(define ghc-show-combinators
(define ghc-exit-codes
(package
(name "ghc-show-combinators")
(version "0.2.0.0")
(source
(origin
(name "ghc-exit-codes")
(version "1.0.0")
(source (origin
(method url-fetch)
(uri (hackage-uri "show-combinators" version))
(uri (hackage-uri "exit-codes" version))
(sha256
(base32 "07ds87ldl9165hj3k5h84iawc6vqlbggni3dg1nhbxww1spxn0n9"))))
(base32
"00cyli96zkyqhjr3lqzrislqyk72xwm2dcqvjagklidh32d4k8ja"))))
(build-system haskell-build-system)
(properties '((upstream-name . "show-combinators")))
(arguments
`(#:cabal-revision ("2"
"0n3xlpm41wpw1ybmacg9s7150nx00qrdlw2rq4fzz7iw7333cyjx")))
(home-page "https://github.com/Lysxia/show-combinators#readme")
(synopsis "Combinators to write Show instances")
(properties '((upstream-name . "exit-codes")))
(home-page "http://github.com/JustusAdam/exit-codes")
(synopsis "Exit codes as defined by BSD")
(description
"This package provides a minimal pretty-printing library for Show instances in
Haskell.")
(license license:expat)))
"Expose the exit codes defined by BSD in sysexits.h to the Haskell world.")
(license license:bsd-3)))
tiedote-md

View File

@ -30,7 +30,7 @@ the tiedote.md user on this system.")
(sendmail-path
(string "/run/privileged/bin/sendmail")
"Path to a sendmail compatible mailing executable.")
(webhook-port
(port
(integer 3000)
"Port to listen on for webhook notifications.")
(socket-path
@ -54,36 +54,10 @@ the tiedote.md user on this system.")
(home-directory state-directory)
(shell (file-append bash-minimal "/bin/bash"))))))
(define (make-tiedote.md-server-script config)
(match-record config <tiedote.md-configuration>
(socket-path email-address sender-name webhook-port sendmail-path
remote-branch remote-url state-directory)
(program-file "tiedote.md-server"
#~(begin
; use utf8 before starting tiedote.md to be able to pass utf characters as arguments
(setlocale LC_ALL "C.UTF-8")
; use utf8 after exec so that ghc text library doesn't crash from IO
(setenv "LANG" "C.UTF-8")
(let ((tiedote.md #$(file-append tiedote-md "/bin/tiedote.md"))
(repo-path (string-append #$state-directory "/git-repo")))
(apply execl
`(,tiedote.md
,tiedote.md
"--address" #$email-address
"--sender-name" #$sender-name
"--sendmail" #$sendmail-path
"--socket" #$socket-path
"server"
"--repository" ,repo-path
"--port" #$(number->string webhook-port)
"--remote-url" #$remote-url
,@(if #$(maybe-value-set? remote-branch)
(list "--remote-branch" #$remote-branch)
'()))))))))
(define (tiedote.md-shepherd-service config)
(match-record config <tiedote.md-configuration>
(state-directory socket-path)
(state-directory socket-path email-address sender-name port sendmail-path
remote-branch remote-url)
(list (shepherd-service
(documentation "A simple mass email system")
(requirement '(networking user-processes))
@ -91,46 +65,48 @@ the tiedote.md user on this system.")
(start #~(let* ((user (getpw "tiedote.md"))
(uid (passwd:uid user))
(gid (passwd:gid user))
(socket-directory (dirname #$socket-path)))
(socket-directory (dirname #$socket-path))
(repo-path (string-append #$state-directory "/git-repo")))
(begin
(mkdir-p socket-directory)
(chown socket-directory uid gid)
(make-forkexec-constructor (list #$(make-tiedote.md-server-script config))
(make-forkexec-constructor
(list #$(file-append tiedote-md "/bin/tiedote.md")
"--address" #$email-address
"--sender-name" #$sender-name
"--sendmail" #$sendmail-path
"--socket" #$socket-path
"server"
"--repository" repo-path
"--port" #$(number->string port)
"--remote-url" #$remote-url
;,@(if #$(maybe-value-set? remote-branch)
; (list "--remote-branch" #$remote-branch)
; '())
)
#:user "tiedote.md"
#:group "tiedote.md"
#:environment-variables
(cons* "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt"
(default-environment-variables))
#:environment (cons "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt"
(default-environment-variable))
#:directory #$state-directory))))
(stop #~(make-kill-destructor))))))
(define (tiedote.md-activation config)
(match-record config <tiedote.md-configuration>
(state-directory email-address sender-name sendmail-path socket-path)
(let* ((tiedote.md (file-append tiedote-md "/bin/tiedote.md"))
(receive-exec (list tiedote.md ; file to exec
tiedote.md ; arg $0
(let* ((receive-exec (list (file-append tiedote-md "/bin/tiedote.md") ; file to exec
(file-append tiedote-md "/bin/tiedote.md") ; arg $0
"--address" email-address
"--sender-name" sender-name
"--sendmail" sendmail-path
"--socket" socket-path
"receive"))
"--socket" socket-path))
(receive-script (program-file "tiedote.md-receive"
#~(begin
(setlocale LC_ALL "C.UTF-8")
(setenv "LANG" "C.UTF-8")
(apply execl '#$receive-exec))))
#~(apply execl #$receive-exec)))
(forward-file (mixed-text-file "dot-forward" "|" receive-script)))
#~(let* ((.forward (string-append #$state-directory "/.forward"))
(user (getpw "tiedote.md"))
(uid (passwd:uid user))
(gid (passwd:gid user)))
#~(let ((.forward (string-append #$state-directory "/.forward")))
(if (file-exists? .forward)
(delete-file .forward))
; smtpd does not follow symbolic links and requires .forward files to
; be owned by the recipient
(copy-file #$forward-file .forward)
(chown .forward uid gid)))))
(symlink #$forward-file .forward)))))
(define tiedote.md-service-type
(service-type

View File

@ -1,149 +0,0 @@
From 8179aba8aa35ac3fa518a2a398b0f66b67092433 Mon Sep 17 00:00:00 2001
From: Saku Laesvuori <saku@laesvuori.fi>
Date: Wed, 5 Aug 2026 10:28:41 +0300
Subject: [PATCH] Add Template Haskell Lift instance for Doc
---
doclayout.cabal | 1 +
src/Text/DocLayout.hs | 4 +++-
src/Text/DocLayout/ANSIFont.hs | 20 +++++++++++---------
src/Text/DocLayout/Attributed.hs | 6 ++++--
4 files changed, 19 insertions(+), 12 deletions(-)
diff --git a/doclayout.cabal b/doclayout.cabal
index 83ad188..ff3b545 100644
--- a/doclayout.cabal
+++ b/doclayout.cabal
@@ -32,6 +32,7 @@ library
containers,
emojis >=0.1.2,
mtl,
+ template-haskell-lift,
safe
default-language: Haskell2010
ghc-options: -Wall -fno-warn-unused-do-bind
diff --git a/src/Text/DocLayout.hs b/src/Text/DocLayout.hs
index d4ff1b3..7c252df 100644
--- a/src/Text/DocLayout.hs
+++ b/src/Text/DocLayout.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
@@ -127,6 +128,7 @@ import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
+import Language.Haskell.TH.Lift (Lift)
import Text.DocLayout.HasChars
import Text.DocLayout.ANSIFont
import Text.DocLayout.Attributed
@@ -159,7 +161,7 @@ data Doc a = Text Int a -- ^ Text with specified width.
| Linked Text (Doc a) -- ^ A hyperlink
| Empty
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable,
- Data, Typeable, Generic)
+ Data, Typeable, Generic, Lift)
instance Semigroup (Doc a) where
diff --git a/src/Text/DocLayout/ANSIFont.hs b/src/Text/DocLayout/ANSIFont.hs
index b952d0b..7002f92 100644
--- a/src/Text/DocLayout/ANSIFont.hs
+++ b/src/Text/DocLayout/ANSIFont.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveLift #-}
module Text.DocLayout.ANSIFont
( Font(..)
, baseFont
@@ -17,6 +18,7 @@ module Text.DocLayout.ANSIFont
) where
import Data.Data (Data)
+import Language.Haskell.TH.Lift (Lift)
import Data.String
import Data.Text (Text)
@@ -29,18 +31,18 @@ data Font = Font
ftBackground :: Background,
ftLink :: Maybe Text
}
- deriving (Show, Eq, Read, Data, Ord)
+ deriving (Show, Eq, Read, Data, Ord, Lift)
baseFont :: Font
baseFont = Font Normal Roman ULNone Unstruck FGDefault BGDefault Nothing
-data Weight = Normal | Bold deriving (Show, Eq, Read, Data, Ord)
-data Shape = Roman | Italic deriving (Show, Eq, Read, Data, Ord)
-data Color8 = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White deriving (Show, Eq, Enum, Read, Data, Ord)
-data Underline = ULNone | ULSingle | ULDouble | ULCurly deriving (Show, Eq, Read, Data, Ord)
-data Strikeout = Unstruck | Struck deriving (Show, Eq, Read, Data, Ord)
-data Foreground = FGDefault | FG Color8 deriving (Show, Eq, Read, Data, Ord)
-data Background = BGDefault | BG Color8 deriving (Show, Eq, Read, Data, Ord)
+data Weight = Normal | Bold deriving (Show, Eq, Read, Data, Ord, Lift)
+data Shape = Roman | Italic deriving (Show, Eq, Read, Data, Ord, Lift)
+data Color8 = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White deriving (Show, Eq, Enum, Read, Data, Ord, Lift)
+data Underline = ULNone | ULSingle | ULDouble | ULCurly deriving (Show, Eq, Read, Data, Ord, Lift)
+data Strikeout = Unstruck | Struck deriving (Show, Eq, Read, Data, Ord, Lift)
+data Foreground = FGDefault | FG Color8 deriving (Show, Eq, Read, Data, Ord, Lift)
+data Background = BGDefault | BG Color8 deriving (Show, Eq, Read, Data, Ord, Lift)
data StyleReq
= RWeight Weight
@@ -49,7 +51,7 @@ data StyleReq
| RBackground Background
| RUnderline Underline
| RStrikeout Strikeout
- deriving (Show, Eq, Read, Data, Ord)
+ deriving (Show, Eq, Read, Data, Ord, Lift)
(~>) :: Font -> StyleReq -> Font
(~>) f (RWeight w) = f{ftWeight = w}
diff --git a/src/Text/DocLayout/Attributed.hs b/src/Text/DocLayout/Attributed.hs
index 46574a1..24124c3 100644
--- a/src/Text/DocLayout/Attributed.hs
+++ b/src/Text/DocLayout/Attributed.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -9,6 +10,7 @@ import Data.String
import Text.DocLayout.ANSIFont (Font, baseFont)
import Data.Data (Data, Typeable)
import GHC.Generics
+import Language.Haskell.TH.Lift (Lift)
import Data.Sequence ((><))
import qualified Data.Sequence as S
import Data.Text (Text)
@@ -18,7 +20,7 @@ type Link = Maybe Text
-- | Font attributes.
data Attr a = Attr Link Font a
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable,
- Data, Typeable, Generic)
+ Data, Typeable, Generic, Lift)
instance Semigroup a => Semigroup (Attr a) where
(<>) (Attr l f x) (Attr _ _ y) = Attr l f $ x <> y -- This is arbitrary
@@ -29,7 +31,7 @@ instance (IsString a, Monoid a) => Monoid (Attr a) where
-- | A sequence of strings with font attributes.
newtype Attributed a = Attributed (S.Seq (Attr a))
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable,
- Data, Typeable, Generic)
+ Data, Typeable, Generic, Lift)
fromList :: [Attr a] -> Attributed a
fromList = Attributed . S.fromList
base-commit: aa2e9d853b7c26f49d3b540f7ca0625e612503ce
--
2.54.0

View File

@ -41,7 +41,9 @@ lähettämisestä ja Git-tietovaraston päivittämisestä, kun se saa muutoksist
ilmoituksen HTTP POST -pyyntönä (esim. Git-palvelun webhookista).
Palvelimen voi käynnistää komennolla `tiedote.md server`. Mahdolliset asetukset
saa listattua lisäämällä komentoon `--help` valitsimen.
saa listattua lisäämällä komentoon `--help` valitsimen. `--address`
valitsimesta tulee huomata, että osoitteessa voi käyttää vain ASCII-merkkejä
(ks. [#15](https://git.olarinmaensamoojat.fi/OMS/tiedote.md/issues/15)).
Sähköpostin lähettämiseen tarvitaan `sendmail`-yhteensopiva MTA (mail transfer
agent, sähköpostin välitysohjelma), jollaisen useimmat sähköpostipalvelimet

View File

@ -3,7 +3,7 @@
(url "https://git.savannah.gnu.org/git/guix.git")
(branch "master")
(commit
"86813d5779253bb50002d79ab791eeda5a8b4729")
"a6fc564bcc32ba599fc701f340c2d59c47bb225b")
(introduction
(make-channel-introduction
"9edb3f66fd807b096b48283debdcddccfea34bad"

View File

@ -22,7 +22,7 @@ import System.Directory (findExecutable)
import System.Exit (exitWith)
import System.Exit.Codes (codeTempFail)
import System.Posix.User (getRealUserID, userName, getUserEntryForID)
import Web.Scotty (scotty, post, liftIO, defaultHandler, Handler(Handler), ScottyException)
import Web.Scotty (scotty, post, liftAndCatchIO, defaultHandler)
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as LT
@ -41,8 +41,8 @@ serverMain socket mail repoPath origin sendmailPath checkpointDelay port = do
_ <- forkIO $ acidServerSockAddr skipAuthenticationCheck socket acid
queueMessages acid
_ <- forkIO $ scotty port $ do
defaultHandler $ Handler $ liftIO . (print :: ScottyException -> IO ())
post "/" $ liftIO $ void $ forkIO $ updateMessages acid repoPath origin
defaultHandler $ liftAndCatchIO . LT.putStrLn -- Don't return exceptions to clients
post "/" $ liftAndCatchIO $ void $ forkIO $ updateMessages acid repoPath origin
updateMessages acid repoPath origin
_ <- forkIO $ manageQueueingMessages acid
_ <- forkIO $ managePreviews acid mail sendmailPath

View File

@ -18,7 +18,6 @@ import Data.Bifunctor (first, second)
import Data.ByteArray (convert)
import Data.ByteString (ByteString)
import "base64" Data.ByteString.Base64.URL
import Data.Base64.Types (extractBase64)
import Data.Default (def)
import Data.Either (rights, lefts, fromRight)
import Data.FileStore (FileStore(..), Revision(..), FileStoreError(..), gitFileStore)
@ -129,7 +128,7 @@ readMessageFile store file = retrieve store file Nothing >>=
cidOf :: MediaItem -> ContentID
cidOf MediaItem {mediaContents, mediaMimeType} =
fromRight (error "makeContentID failed with valid input!") $
makeContentID $ "<" <> extractBase64 encodedHash <> "@tiedote.md.sha256>"
makeContentID $ "<" <> encodedHash <> "@tiedote.md.sha256>"
where encodedHash = encodeBase64' $ convert $ hashWith SHA256 $
LBS.toStrict mediaContents <> encodeUtf8 mediaMimeType

View File

@ -103,11 +103,8 @@ parseEmail = first (EmailParseError . T.pack) . parse (message mime)
getEmailsFromMessage :: MIMEMessage -> [Email]
getEmailsFromMessage = readEmails . toListOf
(entities . transferDecoded' . _Right . charsetText' defaultCharsets . _Right)
-- Windows is broken and reports text/csv as application/vnd.ms-excel...
-- Purebred-email tries to decode non-text entities as utf-8 which should
-- work in this case. It is unlikely that any entity would accidentally
-- contain enough valid addresses on their own lines to fool readEmails.
(entities . filtered isText . transferDecoded' . _Right . charsetText' defaultCharsets . _Right)
where isText = matchContentType "text" Nothing . view contentType
readEmails :: [T.Text] -> [Email]
readEmails = fromMaybe [] . listToMaybe . reverse . sortBy (comparing length) .

View File

@ -4,6 +4,7 @@
module TiedoteMD.Send where
import Control.Concurrent (threadDelay)
import Control.Exception (throwIO)
import Control.Lens (set, _Just)
import Control.Monad (forever, unless)
import Data.Acid (AcidState, query, update)
@ -14,7 +15,8 @@ import Data.MIME.Charset (defaultCharsets)
import Data.Set (Set)
import Data.Time (getCurrentTime)
import System.Exit (ExitCode(..))
import System.IO (hClose, stdout, stderr)
import System.Exit.Codes (codeTempFail)
import System.IO (hClose, stdout)
import System.Process (CreateProcess(..), StdStream(..), waitForProcess, createProcess, proc)
import System.Random (getStdRandom, uniform)
@ -23,25 +25,18 @@ import qualified Data.IMF as IMF
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import TiedoteMD.State
import TiedoteMD.Types
sendmail :: FilePath -> LBS.ByteString -> IO ()
sendmail path bs = do
(Just stdin, _, Just stderr, processHandle) <- createProcess
(proc path ["-t"]) {std_in = CreatePipe, std_err = CreatePipe}
(Just stdin, _, _, processHandle) <- createProcess (proc path ["-t"]) {std_in = CreatePipe}
LBS.hPut stdin bs
hClose stdin
errors <- T.hGetContents stderr
exitCode <- waitForProcess processHandle
-- TODO: handle System.Exit.Codes.codeTempFail differently from other failures
unless (exitCode == ExitSuccess) $ do
T.hPutStr System.IO.stderr $
"Sending mail with " <> (T.pack path) <> " failed with " <> (T.pack $ show exitCode)
unless (T.null errors) $ T.hPutStrLn System.IO.stderr $ ":\n" <> errors
T.hPutStrLn System.IO.stderr ""
unless (exitCode `elem` [ExitSuccess, codeTempFail]) $
throwIO $ ProcessError (T.pack path) exitCode
manageQueue :: AcidState State -> Mailbox -> FilePath -> IO ()
manageQueue acid sender sendmailPath = forever $ do

View File

@ -8,6 +8,7 @@ module TiedoteMD.Templates.TH where
import Control.Exception (throwIO)
import Data.FileEmbed
import Language.Haskell.TH.Syntax (Q, Exp, Lift, runIO, lift, Quasi(qAddDependentFile))
import Text.DocLayout (Doc(..))
import Text.DocTemplates.Internal (Variable(..), Pipe(..), Alignment(..), Border(..), Template(..))
import Text.Pandoc (compileTemplate)
@ -16,6 +17,7 @@ import qualified Data.Text.IO as T
import TiedoteMD.Types
deriving instance Lift (Doc T.Text)
deriving instance Lift (Template T.Text)
deriving instance Lift Alignment
deriving instance Lift Border

View File

@ -1,6 +1,6 @@
cabal-version: 3.6
name: tiedote-md
version: 0.0.2
version: 0.0.1
author: Saku Laesvuori
maintainer: saku@laesvuori.fi
bug-reports: https://git.olarinmaensamoojat.fi/OMS/tiedote.md/issues
@ -30,7 +30,7 @@ executable tiedote.md
bytestring,
case-insensitive,
containers,
crypton,
cryptonite,
data-default,
directory,
doclayout,
@ -67,6 +67,7 @@ executable tiedote.md
TiedoteMD.Send
TiedoteMD.State
TiedoteMD.Templates
TiedoteMD.Templates
TiedoteMD.Templates.TH
TiedoteMD.Types
hs-source-dirs: src