0 | module Data.Regex.CommonRegexes
 1 |
 2 | import Data.Regex
 3 |
 4 | import Data.String
 5 | import Data.List
 6 | import Data.Maybe
 7 |
 8 | ||| Simple email regex
 9 | export
10 | email : TyRE (String, String, String)
11 | email = 
12 |     let firstPart : TyRE String
13 |         firstPart = fastPack `map` rep1 ((letter `or` digitChar) `or` oneOfChars "%+_.-")
14 |         secondPart : TyRE String
15 |         secondPart = (joinBy ".") `map` rep1 (fastPack `map` rep1 (letter `or` digitChar) <* match '.')
16 |         domain : TyRE String
17 |         domain = fastPack `map` repFromTo 2 6 letter
18 |     in firstPart <*> (match '@' *> secondPart <*> domain)
19 |
20 | ---password validation
21 | data PasswordValidationError    = NoDigit 
22 |                                 | NoCapitalLetter 
23 |                                 | NoLowerCaseLetter 
24 |                                 | NoSpecialCharacter 
25 |                                 | ContainsSpace
26 |
27 | passwordStrength : List ((TyRE (), PasswordValidationError))
28 | passwordStrength =
29 |     let hasDigit := r ".*[0-9].*"
30 |         hasCapitalLetter := r ".*[A-Z].*"
31 |         hasLowerCaseLetter := r ".*[a-z].*"
32 |         hasSpecialCharacter := r "[@#$<>%^&:=,_\\*\\+\\.\\?\\-\\!]"
33 |         doesntHaveSpaces := ignore $ rep0 $ predicate (/= ' ')
34 |     in  [ (hasDigit, NoDigit)
35 |         , (hasCapitalLetter, NoCapitalLetter)
36 |         , (hasLowerCaseLetter, NoLowerCaseLetter)
37 |         , (hasSpecialCharacter, NoSpecialCharacter)
38 |         , (doesntHaveSpaces, ContainsSpace)
39 |         ]
40 |
41 | ||| Strong password validation 
42 | export
43 | validatePasswordSecurity : String -> List PasswordValidationError
44 | validatePasswordSecurity str = 
45 |     passwordStrength >>= f where
46 |         f : (TyRE (), PasswordValidationError) -> List PasswordValidationError
47 |         f (tyre, error) = if match tyre str then [] else [error]
48 |
49 | --- url
50 | namespace UrlRegex
51 |     export
52 |     record URL where
53 |         constructor HTTP
54 |         isSSL : Maybe Bool
55 |         host : (String, String)
56 |         path : List String
57 |         query : Maybe (List (String, String))
58 |         fragment : Maybe String
59 |         
60 |     export
61 |     Show URL where
62 |         show (HTTP isSSL (host, domain) path query fragment) = 
63 |             let protocol := 
64 |                     case isSSL of
65 |                         Nothing => ""
66 |                         (Just True) => "https://"
67 |                         (Just False) => "http://"
68 |                 pathPart := joinBy "/" path
69 |                 queryPart := map ((joinBy "&") . (map (\case (p, v) => p ++ "=" ++ v))) query
70 |             in protocol ++ host ++ "." ++ domain ++ pathPart ++ fromMaybe "" queryPart ++ fromMaybe "" fragment
71 |
72 |     export
73 |     url : TyRE URL
74 |     url = (\case (pr, h, p, q, f) => HTTP pr h p q f) 
75 |           `map` 
76 |           (protocol <*> (host <*> (path <*> (query <*> fragment)))) where
77 |             digitLetterOr : String -> TyRE Char
78 |             digitLetterOr str = (digitChar `or` letter) `or` oneOfChars str
79 |             
80 |             protocol : TyRE (Maybe Bool)
81 |             protocol = r "((https?)!://(www)?)?"
82 |
83 |             host : TyRE (String, String)
84 |             host =  (fastPack `map` rep1 (digitLetterOr "@:%_~#=.+-\\"))
85 |                     <* match '.' 
86 |                     <*> (fastPack `map` repFromTo 1 6 (digitLetterOr "()"))
87 |
88 |             path : TyRE (List String)
89 |             path = rep0 (match '/' *> (fastPack `map` rep1 (digitLetterOr "_-")))
90 |
91 |             query : TyRE (Maybe (List (String, String)))
92 |             query = TyRE.Core.option $ match '?' 
93 |                         *> rep1 ((fastPack `map` rep1 (digitLetterOr "_-") 
94 |                             <* match '=') 
95 |                         <*> (fastPack `map` rep1 (digitLetterOr "_-")))
96 |
97 |             fragment : TyRE (Maybe String)
98 |             fragment = TyRE.Core.option $ match '#' *> (fastPack `map` rep1 (digitLetterOr "_-"))