1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hsm.GPIO
( GPIO(..)
, GPIOEffect
, G.LineValue
, G.active
, G.inactive
, setPins
, setAllPins
, runGPIO
) where
import Control.Monad (forM_, void)
import Data.Aeson (FromJSON)
import Data.ByteString (useAsCString)
import Data.Kind (Type)
import Data.Set (Set, size, toList, unions)
import Data.String (IsString)
import Data.Text (Text, pack)
import Data.Text.Encoding (encodeUtf8)
import Data.Vector.Storable qualified as V
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
import Effectful.Dispatch.Static qualified as E
import Effectful.Exception (finally)
import Effectful.Log (Log, LogLevel(LogTrace), localDomain, logTrace_)
import Effectful.Reader.Static (Reader, ask)
import Effectful.Resource (Resource, allocate, release)
import Foreign.C.Types (CSize(CSize), CUInt(CUInt))
import Foreign.Ptr (Ptr)
import GHC.Generics (Generic)
import GHC.Records (HasField)
import Hsm.Core.Log (flushLogger, withLogIO)
import Hsm.GPIO.Lib qualified as G
data GPIO
= GPIO5
| GPIO6
| GPIO16
| GPIO17
| GPIO22
| GPIO23
| GPIO24
| GPIO25
| GPIO26
| GPIO27
deriving (Eq, FromJSON, Generic, Ord, Read, Show)
gpiosMapped ::
forall key. (Bounded key, Enum key)
=> (key -> Set GPIO)
-> Set GPIO
gpiosMapped mapper = unions $ mapper <$> [minBound @key .. maxBound]
gpioLine :: GPIO -> CUInt
gpioLine = CUInt . read . drop 4 . show
data GPIOEffect key a b
type instance DispatchOf (GPIOEffect key) = Static E.WithSideEffects
-- The static representation of this effect contains a function that maps a
-- `key` to a `Set` of GPIO pins. This allows a single `key` of any type to
-- control multiple pins simultaneously. By using a function (instead of
-- `Data.Map`), we ensure that the mapping is total, meaning every `key` will
-- map to a corresponding set of pins.
data instance E.StaticRep (GPIOEffect (key :: Type)) =
GPIOEffect (key -> Set GPIO) (Ptr G.LineRequest)
domain :: Text
domain = "gpio"
chipPath :: IsString a => a
chipPath = "/dev/gpiochip0"
setPins ::
(GPIOEffect key :> es, Log :> es, Show key)
=> G.LineValue
-> key
-> Eff es ()
setPins lineValue key = do
GPIOEffect mapper lineRequest <- E.getStaticRep
forM_ (mapper key) $ \pin -> do
localDomain domain
$ logTrace_
$ "Setting PIN "
<> pack (show pin)
<> " mapped to key "
<> pack (show key)
<> " to state "
<> pack (show lineValue)
flushLogger
E.unsafeEff_ $ G.lineRequestSetValue lineRequest (gpioLine pin) lineValue
setAllPins ::
forall key es. (GPIOEffect key :> es, Log :> es, Bounded key, Enum key)
=> G.LineValue
-> Eff es ()
setAllPins lineValue = E.getStaticRep >>= setter
where
setter (GPIOEffect mapper lineRequest) = do
localDomain domain
$ logTrace_
$ "Setting all mapped PINs "
<> pack (show mapped)
<> " to state "
<> pack (show lineValue)
flushLogger
void
$ E.unsafeEff_
$ V.unsafeWith lineValuesVector
$ G.lineRequestSetValues lineRequest
where
mapped = gpiosMapped @key mapper
lineValuesVector = V.replicate (size mapped) lineValue
runGPIO ::
forall env es key a.
( HasField "name" env Text
, IOE :> es
, Log :> es
, Reader env :> es
, Resource :> es
, Bounded key
, Enum key
)
=> (key -> Set GPIO)
-> Eff (GPIOEffect key : es) a
-> Eff es a
runGPIO mapper action = do
lineRequest <- localDomain domain $ withLogIO >>= bootstrap
E.evalStaticRep (GPIOEffect mapper lineRequest)
$ finally action
$ setAllPins @key G.inactive
where
bootstrap logIO = do
(chipKey, chip) <- allocate chipOpen chipClose
(lineSettingsKey, lineSettings) <-
allocate lineSettingsNew lineSettingsFree
(lineConfigKey, lineConfig) <-
allocate (lineConfigNew lineSettings) lineConfigFree
env <- ask @env
(requestConfigKey, requestConfig) <-
allocate (requestConfigNew env.name) requestConfigFree
(_, lineRequest) <-
allocate (requestLines chip requestConfig lineConfig) lineRequestRelease
release requestConfigKey
release lineConfigKey
release lineSettingsKey
release chipKey
return lineRequest
where
gpiosVector = V.fromList $ gpioLine <$> toList (gpiosMapped mapper)
gpiosSize = CSize $ fromIntegral $ V.length gpiosVector
chipOpen = do
logIO LogTrace $ "Opening GPIO chip " <> chipPath
useAsCString chipPath G.chipOpen
chipClose chip = do
logIO LogTrace $ "Closing GPIO chip " <> chipPath
G.chipClose chip
lineSettingsNew = do
logIO LogTrace "Allocating line settings"
lineSettings <- G.lineSettingsNew
logIO LogTrace $ "With direction set to " <> pack (show G.output)
void $ G.lineSettingsSetDirection lineSettings G.output
logIO LogTrace $ "With output set to " <> pack (show G.inactive)
void $ G.lineSettingsSetOutputValue lineSettings G.inactive
return lineSettings
lineSettingsFree lineSettings = do
logIO LogTrace "Freeing line settings"
G.lineSettingsFree lineSettings
lineConfigNew lineSettings = do
logIO LogTrace "Allocating line config"
logIO LogTrace $ "With GPIOs " <> pack (show gpiosVector)
lineConfig <- G.lineConfigNew
void
$ V.unsafeWith gpiosVector
$ \gpiosPtr ->
G.lineConfigAddLineSettings
lineConfig
gpiosPtr
gpiosSize
lineSettings
return lineConfig
lineConfigFree lineConfig = do
logIO LogTrace "Freeing line config"
G.lineConfigFree lineConfig
requestConfigNew consumer = do
logIO LogTrace "Allocating request config"
logIO LogTrace $ "With consumer " <> consumer
requestConfig <- G.requestConfigNew
useAsCString (encodeUtf8 consumer)
$ G.requestConfigSetConsumer requestConfig
return requestConfig
requestConfigFree requestConfig = do
logIO LogTrace "Freeing request config"
G.requestConfigFree requestConfig
requestLines chip requestConfig lineConfig = do
logIO LogTrace "Requesting lines from chip"
G.requestLines chip requestConfig lineConfig
lineRequestRelease lineRequest = do
logIO LogTrace "Releasing lines"
G.lineRequestRelease lineRequest
|
