user@personal:~/code/haskell/mac/src$ ll
total 5K
-rwxr-xr-x 1 user user 5.0K Jan 15 23:41 MAC.hs*
user@personal:~/code/haskell/mac/src$ 

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
#!/usr/bin/env stack
{- stack
   --resolver lts-12.0
   --install-ghc
   script
   --ghc-options -Werror
   --ghc-options -Wall
   --
-}

--------------------------------------------------------------------------------

{-# LANGUAGE EmptyDataDecls        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}

--------------------------------------------------------------------------------

module Main (main) where

--------------------------------------------------------------------------------

import           Data.List
    ( isInfixOf
    )

--------------------------------------------------------------------------------

import           System.IO.Unsafe
    ( unsafePerformIO
    )

--------------------------------------------------------------------------------
-- Mandatory Access Control (MAC)
--------------------------------------------------------------------------------

import qualified Control.Exception as Ex
import           Control.Monad
    ( ap
    , liftM
    )

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

data P -- Public
data S -- Secret

--------------------------------------------------------------------------------

class Flow l l'              where
class Flow l l' => Less l l' where

--------------------------------------------------------------------------------

instance Flow P P where
instance Flow P S where
instance Flow S S where

instance Less P P where
instance Less P S where
instance Less S S where

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

newtype MAC p a = M { mac :: IO a }

--------------------------------------------------------------------------------

instance Functor     (MAC p) where
  fmap = liftM
instance Applicative (MAC p) where
  pure  = return
  (<*>) = ap
instance Monad       (MAC p) where
  return  a = M $ pure a
  (>>=) m f = M $ mac  m >>= mac . f

--------------------------------------------------------------------------------

lift :: IO a -> MAC p a
lift = M

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

data    UID   a = U { uid  :: a }
newtype RES p a = R { res  :: a }
type    LAB l a = RES l ( UID a )

--------------------------------------------------------------------------------

label :: Less l l' => a -> MAC l (LAB l' a)
label =
  create . pure . U
  where
    create io = lift io >>= pure . R

unlabel :: Less l' l => LAB l' a -> MAC l a
unlabel =
  readdown $ pure . uid
  where
    readdown io x = lift $ io $ res x

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

bind :: Less l l' => MAC l' a -> MAC l (LAB l' a)
bind m =
  (lift . mac) (trycatch m) >>= label
  where
    trycatch x = catch x (\(e :: Ex.SomeException) -> throw e)

throw :: Ex.Exception e => e -> MAC l a
throw = lift . Ex.throw

catch :: Ex.Exception e => MAC l a -> (e -> MAC l a) -> MAC l a
catch (M io) x = lift $ Ex.catch io $ mac . x

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

-- (offline) common pwds library
-- Note: For simplicity, replace `wget^MAC` with a simple `offline^MAC`

offline :: MAC P String
offline =
  lift $ pure
  -- Top 10 most common passwords:
  -- https://en.wikipedia.org/wiki/List_of_the_most_common_passwords#SplashData
  "password\
  \123456789\
  \111111\
  \sunshine\
  \qwerty\
  \iloveyou"

--------------------------------------------------------------------------------

-- Bob library needs to be in a separated library/module which `must` be marked
-- as `SAFE` in order to avoid the usage of `unsafePerformIO` and so.

common :: LAB S String -> MAC P (LAB S Bool)
common lpwd =
  do
    -- We can't access `lpwd` in the root monad. We need to use the MAC `bind`
    -- as it allows to operate on data, but it can't leak in the sense that we
    -- can't send it to the server where we retrieve the passwords.
    --
    -- * No instance for (Less S P) arising from a use of ‘unlabel’
    --
    --pwd <- unlabel lpwd
    off <- offline
    bind $
      (
        do
          pwd <- unlabel lpwd
          pure $ (evil pwd) `isInfixOf` off
      )
    where
      evil x = unsafePerformIO (putStrLn x >> pure x)

--------------------------------------------------------------------------------

-- Alice

password :: IO String
password =
  do
    putStr "Please, select your password: "
    pwd <- getLine
    val <- mac $ (label pwd) >>= common
    if (uid . res) val
      then putStrLn "It's a common password!" >> password
      else pure pwd

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

main :: IO ()
main =
  password >>= putStrLn . (++) "Valid password is: "

user@personal:~/code/haskell/mac/src$ ./MAC.hs
Please, select your password: pass
pass
It's a common password!
Please, select your password: word
word
It's a common password!
Please, select your password: 1234
1234
It's a common password!
Please, select your password: 5678 
5678
It's a common password!
Please, select your password: pass1234
pass1234
Valid password is: pass1234
user@personal:~/code/haskell/mac/src$